Config-Model-2.149/0000755000175000017500000000000014170053137012437 5ustar domidomiConfig-Model-2.149/README.md0000644000175000017500000001474614170053137013732 0ustar domidomi# Config-Model Configuration schema on steroids. [![](https://travis-ci.org/dod38fr/config-model.svg?branch=master)](https://travis-ci.org/dod38fr/config-model) [![](https://badges.gitter.im/dod38fr/config-model.svg)](https://gitter.im/dod38fr/config-model?utm_source=badge&utm_medium=badge&utm_campaign=pr-badge&utm_content=badge) # What is Config-Model project [Config::Model](https://metacpan.org/pod/Config::Model) is: * a set of configuration editor and validator for several projects like [OpenSSH](http://www.openssh.com/), [Systemd](https://freedesktop.org/wiki/Software/systemd/), [LcdProc](http://www.lcdproc.org/)... See [full list of Configuration editors](https://github.com/dod38fr/config-model/wiki/Available-models-and-backends#Available_models_and_configuration_editors) * a framework that enables a project developer (or any advance user) to provide a configuration editor and validator to his users. To generate a configuration editor and validator for a project, [Config::Model](https://metacpan.org/pod/Config::Model) needs: * a description of the structure and constraints of a project configuration. (this is called a model, but could also be called a schema) * a way to read and write configuration data. This can be provided by [built-in read/write backends](https://github.com/dod38fr/config-model/wiki/Available-models-and-backends#Available_backend) or by a [new read/write backend](http://search.cpan.org/dist/Config-Model/lib/Config/Model/Backend/Any.pm#How_to_write_your_own_backend). With the elements above, [Config::Model](https://metacpan.org/pod/Config::Model) generates interactive configuration editors (with integrated help and data validation) and support several kinds of user interface, e.g. graphical, interactive command line. See the [list of available user interfaces](https://github.com/dod38fr/config-model/wiki/Available-models-and-backends#Available_user_interfaces) ## Installation See [installation instructions](https://github.com/dod38fr/config-model/blob/master/README.install.pod). Perl developers can also [build Config::Model from git](build-from-git.md) ## Getting started * To manage your configuration files with existing modules, see [Using cme wiki page](https://github.com/dod38fr/config-model/wiki/Using-cme) * To create configuration tools for your favorite project, see this [introduction to model creation](https://metacpan.org/pod/Config::Model::Manual::ModelCreationIntroduction) ## How does this work ? Using this project, a typical configuration editor will be made of 3 parts : 1. The user interface ( [cme](http://search.cpan.org/dist/Config-Model/script/cme) program and some other optional modules) 2. The validation engine which is in charge of validating all the configuration information provided by the user. This engine is made of the framework provided by this module and the configuration description (often referred as "configuration model", this could also be known as a schema). 3. The storage facility that store the configuration information (currently several backends are provided: ini files, perl files) The important part is the configuration model used by the validation engine. This model can be created or modified with a graphical editor ([cme meta edit](http://search.cpan.org/dist/Config-Model-Itself/lib/App/Cme/Command/meta.pm) provided by [Config::Model::Itself](https://metacpan.org/pod/Config::Model::Itself)). ## Don't we already have some configuration validation tools ? You're probably thinking of tools like webmin. Yes, these tools exist and work fine, but they have their set of drawbacks. Usually, the validation of configuration data is done with a script which performs semantic validation and often ends up being quite complex (e.g. 2500 lines for Debian's xserver-xorg.config script which handles xorg.conf file). In most cases, the configuration model is expressed in instructions (whatever programming language is used) and interspersed with a lot of processing to handle the actual configuration data. ## What's the advantage of this project ? [Config::Model](https://metacpan.org/pod/Config::Model) projects provide a way to get a validation engine where the configuration model is completely separated from the actual processing instructions. A configuration model can be created and modified with the graphical interface provided by ["cme meta edit"](#cme-meta-edit) distributed with [Config::Model::Itself](https://metacpan.org/pod/Config::Model::Itself). The model is saved in a declarative form (currently, a Perl data structure). Such a model is easier to maintain than a lot of code. The model specifies: * the structure of the configuration data (which can be queried by generic user interfaces) * the properties of each element (boundaries check, integer or string, enum like type ...) * the default values of parameters (if any) * mandatory parameters * Warning conditions (and optionally, instructions to fix warnings) * on-line help (for each parameter or value of parameter) So, in the end: * maintenance and evolution of the configuration content is easier * user will see a **common** interface for **all** programs using this project. * upgrade of configuration data is easier and sanity check is performed * audit of configuration is possible to check what was modified by the user compared to default values ## What about the user interface ? [Config::Model](https://metacpan.org/pod/Config::Model) interface can be: * a shell-like interface (plain or based on [Term::ReadLine](https://metacpan.org/pod/Term::ReadLine) with [Config::Model::TermUI](https://metacpan.org/pod/Config::Model::TermUI)). * Graphical with [Config::Model::TkUI](https://metacpan.org/pod/Config::Model::TkUI) (Perl/Tk interface). * based on curses with [Config::Model::CursesUI](https://metacpan.org/pod/Config::Model::CursesUI). All these interfaces are generated from the configuration model. And configuration model can be created or modified with a graphical user interface (["cme meta edit"](#cme-meta-edit)) ## What about configuration data storage ? Since the syntax of configuration files vary wildly form one program to another, most people who want to use this framework will have to provide a dedicated parser/writer. Nevertheless, this project provides a writer/parser for some common format: ini style file and perl file. ## More information See * the [config-model wiki](https://github.com/dod38fr/config-model/wiki) (i.e. the wiki tab above) * [https://ddumont.wordpress.com/category/perl/configmodel/](https://ddumont.wordpress.com/category/perl/configmodel/) Config-Model-2.149/README.install.pod0000644000175000017500000000213414170053137015545 0ustar domidomi=head1 Installation =head2 Debian or Ubuntu L and most L modules are provided as Debian package. The following command will install the framework and all available models and UIs: sudo apt-get install --install-recommends --install-suggests cme =head2 Mac OSX L is provided as ppm package by L: =over =item * Install L =item * Update your $PATH variable to run ActiveState's perl =item * Run ppm to install L =back =head2 Windows You can also install L from L. See the instructions for Mac OSX for details. =head2 Fedora Run: yum install perl-Config-Model perl-App-Cme perl-Config-Model-TkUI See L =head2 Other systems For other systems, you should install L from CPAN: cpanp install App::Cme cpanp install Config::Model Config-Model-2.149/META.json0000644000175000017500000000700214170053137014057 0ustar domidomi{ "abstract" : "a framework to validate, migrate and edit configuration files", "author" : [ "Dominique Dumont" ], "dynamic_config" : 0, "generated_by" : "Dist::Zilla version 6.024, CPAN::Meta::Converter version 2.150010", "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" } }, "configure" : { "requires" : { "Module::Build" : "0.34" } }, "develop" : { "requires" : { "Test::Perl::Critic" : "0" } }, "runtime" : { "recommends" : { "Fuse" : "0", "Term::ReadLine" : "0", "Text::Levenshtein::Damerau" : "0" }, "requires" : { "Carp" : "0", "Carp::Assert::More" : "0", "Cwd" : "0", "Data::Dumper" : "0", "Encode" : "0", "English" : "0", "Fcntl" : "0", "File::HomeDir" : "0", "File::Path" : "0", "Hash::Merge" : "0.12", "JSON" : "0", "List::MoreUtils" : "0", "List::Util" : "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.070", "Pod::POM" : "0", "Pod::Simple" : "3.23", "Pod::Text" : "0", "Regexp::Common" : "0", "Scalar::Util" : "0", "Storable" : "0", "Text::Levenshtein::Damerau" : "0", "Text::Wrap" : "0", "YAML::Tiny" : "0", "base" : "0", "feature" : "0", "open" : "0", "overload" : "0", "parent" : "0", "perl" : "v5.20.0", "strict" : "0", "utf8" : "0", "vars" : "0", "warnings" : "0" } }, "test" : { "requires" : { "Config::Model::Tester" : "4.002", "Config::Model::Tester::Setup" : "0", "File::Copy" : "0", "File::Spec" : "0", "IO::File" : "0", "Test::Differences" : "0", "Test::Exception" : "0", "Test::File::Contents" : "0", "Test::Log::Log4perl" : "0", "Test::Memory::Cycle" : "0", "Test::More" : "0", "Test::Perl::Critic" : "0", "Test::Pod" : "1.00", "Test::Warn" : "0.11", "boolean" : "0", "lib" : "0" } } }, "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.149", "x_generated_by_perl" : "v5.32.1", "x_serialization_backend" : "Cpanel::JSON::XS version 4.27", "x_spdx_expression" : "LGPL-2.1" } Config-Model-2.149/weaver.ini0000644000175000017500000000022014170053137014423 0ustar domidomi[@Default] [-Transformer] transformer = List [Support] perldoc = 0 bugs = metadata websites = search,ratings,kwalitee,testers,testmatrix,deps Config-Model-2.149/SIGNATURE0000644000175000017500000005171114170053137013730 0ustar domidomiThis file contains message digests of all files listed in MANIFEST, signed via the Module::Signature module, version 0.88. To verify the content in this distribution, first make sure you have Module::Signature installed, then type: % cpansign -v It will check each file's integrity, as well as the signature's validity. If "==> Signature verified OK! <==" is not displayed, the distribution may already have been compromised, and you should not run its Makefile.PL or Build.PL. -----BEGIN PGP SIGNED MESSAGE----- Hash: RIPEMD160 SHA256 9012121439bad915bc4c999b824429bce708de737a511d24b27b131cd999d8d2 Build.PL SHA256 cbf9519bb376f2aef5855206fb26dabef019f6f71a8f40c93763264e881ac8f4 CONTRIBUTING.md SHA256 805c85fdbfa5448bec1bf2cf297eb764397b27a59dae2abe040ee6de787512cc Changes SHA256 d08e1a24817ec0361ba1f49bcefe416acce3c2144fc8def2ac24d34e11960989 LICENSE SHA256 b031d49f3b7cd41359e45510e22725cde1326060940f6ec06f7fb8983a68ad00 MANIFEST SHA256 d68df94568cdc7d59e14123f79e33d1818d8d5441a2afe9cbe1143c9cd23deae MANIFEST.SKIP SHA256 84b535864a6be3aab262d4443f2eef3232a5059315f8c0b20ed9c4e072b212ca META.json SHA256 462cf3082fbfa8b07e4d62e3e27cbd2eec9cf5c6b120893a38fbec2d6956d602 META.yml SHA256 ad98c473e8676930bee8cd703c98129ba060ddf767a2a5121ba4c75ea1170a13 MODELS SHA256 3ea9eab6dafa86f9ac96e686c1237c728c34f8ed1a2fdeed0aab047fe260d8ee README.install.pod SHA256 3e3a7ec056173307c74af3c11e840f23b3978efbc7df0011132ab821c2cd77a6 README.md SHA256 ce61bb7aae9a6feda21269d5cc65fd8f125ddcc47bf0aeff08c8db133ac5b0de TODO SHA256 bd97d0cb3e032dcfc2372c6237ce41102aaea4407833ce6e14fef078bf70bd8c build-from-git.md SHA256 559cf6d7d52ff4b0a55216de28cc28bcd2bddf2e2dc6463643db4e84d10f1bb9 contrib/bash_completion.cme_multistrap SHA256 f0cc6556bb2bbfe3e67795c8b54a940e2b0df915756ba5e96c9ededede05c675 contrib/log4config-model SHA256 67e27e3d7f07be272b5a5f991abd5a64d959fa573b13ed39b02164e7d4cb42f8 lib/Config/Model.pm SHA256 edeb35106ac71c97a8e662a1f074f8c5f68a1086bd1a91a3b5685342e460078c lib/Config/Model/Annotation.pm SHA256 8513c16af7a957384cc79363bdf1f1b011a9b786f267cc53a9fbf11dfd30f315 lib/Config/Model/AnyId.pm SHA256 021a43e82455e337c64c8bb45e7189584c53741ef06b0af85a6d7e0048cd4b79 lib/Config/Model/AnyThing.pm SHA256 a4e124b45117948f5668500f47f93d6be5b107c19a3dc30e108cf9f1cbf8c45c lib/Config/Model/Backend/Any.pm SHA256 d51da98e4cbc84a9d8f7c47099137e502fa7df114d8dd8f7a1b2596c76856f2d lib/Config/Model/Backend/CdsFile.pm SHA256 0902d3eff5a087d598bdeef7130da85675484b65ae0f0c60686a558e17688d43 lib/Config/Model/Backend/Fstab.pm SHA256 ea757d43d4ba05186f1b23d33cde23ecc3b58cd0362cb129fca179e8dd61b649 lib/Config/Model/Backend/IniFile.pm SHA256 793176b61a4ed106cdd7f231d4a836260079e3231ca16cc3c707c34b0251f6fa lib/Config/Model/Backend/Json.pm SHA256 1d089e0c91b0c7f21c8e32f0d07baffaf344b1521d1ca9a3a9fda72e12330733 lib/Config/Model/Backend/PerlFile.pm SHA256 60b91bc26b260638a28faa984576dd1dea1167592c922e75f0edab9f3f836c56 lib/Config/Model/Backend/PlainFile.pm SHA256 5b9b32f6e212a75e582715c2c636043dc10bf5bb0618ac4409b32bad836963d3 lib/Config/Model/Backend/ShellVar.pm SHA256 7c11698a9edad13f18ecd9506caf93bcf3c6160855d0a0112d209825168ee76f lib/Config/Model/BackendMgr.pm SHA256 f03020debc9ba28f51553f967d9bd60ad9207dee973a5c16e65104e99e50edb7 lib/Config/Model/BackendTrackOrder.pm SHA256 d083d24139271d6ca415123c3e9a1a781e7bf83f2657899cac0a831c812ae3bd lib/Config/Model/CheckList.pm SHA256 cdb2ffb147e6ec4bfc20a6307d9d0420362920faf53bebbdb64a77f377b0b46c lib/Config/Model/Cookbook/CreateModelFromDoc.pod SHA256 fd3ac21ef1732e47ead9dd616ac13b66e2f56117a6f1de602d44ffbe5dd2ed8e lib/Config/Model/Describe.pm SHA256 8db63caa5b0030a127b856ae9e4f73a2c282784d6b62547c0de2fbfdc26fe999 lib/Config/Model/DumpAsData.pm SHA256 770422b714a6482a5ee8ab40ca034dfecf366daee5432021f13e6d84d658bc05 lib/Config/Model/Dumper.pm SHA256 6e10163f28399b7a43a71e1f2d335bfc228d788e6ef550b17e006d8fbeaffd2b lib/Config/Model/Exception.pm SHA256 ba6b1fad548ff6dc15707da716db11eba5b595f1315297c2d749e4bc885b16f5 lib/Config/Model/FuseUI.pm SHA256 cb808c9c9280a4188943f6e2cce69acdc57835cc36512a21e418d979a9930950 lib/Config/Model/HashId.pm SHA256 7f7cbcdd4ca7c44858892840149bd63b892903a7c5b800ec0897449220655e54 lib/Config/Model/IdElementReference.pm SHA256 d73006444573bfc5232b9449b837251920480a323fd3edb5b281b19ff35e2b8e lib/Config/Model/Instance.pm SHA256 956688a5db1982c92dcac171b6eb642ae8ce846d88984c14b42f77cb73f86854 lib/Config/Model/Iterator.pm SHA256 f8e54ec1f50a86af37ee12707ed354ac1c7f44ee7c8b10c30b3961e7f9e9b21f lib/Config/Model/ListId.pm SHA256 976daed5d24892d4c39ff6175a0654a0b2219173db04e9d1aface41d2f928209 lib/Config/Model/Lister.pm SHA256 5da1e8447506f32addfe6178e69b5f914b9ff5eafbe0120e9e41a2338c7468c2 lib/Config/Model/Loader.pm SHA256 eb9cf961dff2123d85d2302fe87bea2c7ac36aff9007e44a8b2b7e66c3875c24 lib/Config/Model/Manual/ModelCreationAdvanced.pod SHA256 6904dc8a2908ec2699d96189bda76e38705c79fa61354700b5b3c74e2fc4d29e lib/Config/Model/Manual/ModelCreationIntroduction.pod SHA256 0bc71d907677741f7b23316970edfd27aa918b6c188aa27fd2e70f15bd2f8620 lib/Config/Model/Node.pm SHA256 ba815a300684984e8790e23666abf237340d39457fbf2eeef90f6e75882239ce lib/Config/Model/ObjTreeScanner.pm SHA256 1d2ff58195dac95c742528adcb60410ad8077acbe6ada0c030a9d239b0601049 lib/Config/Model/Report.pm SHA256 a174d2b2c11f0337767268d0555c477637325d604a015c4bb739ac554fc184ca lib/Config/Model/Role/ComputeFunction.pm SHA256 6403c25b0219973341f60d969994e91d4e69894d0a70bc6abc84fc7abcd130e0 lib/Config/Model/Role/Constants.pm SHA256 47fdb89a7ae91156a08a25eb2ad4ad766a5ef0f6247a1d26143046e81bffd75b lib/Config/Model/Role/FileHandler.pm SHA256 41ae03249d23606d4e39e8d624b9bd43704511ce8d55e5ee5276e80077990bed lib/Config/Model/Role/Grab.pm SHA256 274c5af4d9e951ad3e31a1a0b1c2a18b435545867df6443cdb125983094df921 lib/Config/Model/Role/HelpAsText.pm SHA256 a6768a81a7d3fd1c01ace2f5e6e6a3cf420b0a81097c4925fbf322c8fa812851 lib/Config/Model/Role/NodeLoader.pm SHA256 d0c75ddce2979e41645d542fa8b4b18d548a4d436add8cffd7fff8305a37357d lib/Config/Model/Role/Utils.pm SHA256 18f414135b390f581508a48137298686ea1a417ff04b5020932ddca0bd0daf11 lib/Config/Model/Role/WarpMaster.pm SHA256 2aad9eaba8471d019e91d488385cfed24576e04465bd4ac02a2bc71cae9c5a82 lib/Config/Model/SearchElement.pm SHA256 d06a636113f285dd6cda9c8d8d17caf7d04b9829d02b959ccfee9e6d2591118d lib/Config/Model/SimpleUI.pm SHA256 049529090e0a6582f43f5984f8ae7e66d66d465a2dbbcebc70834e67a036fedb lib/Config/Model/TermUI.pm SHA256 1187f20ab0aae603cc1df71315ca8d54b68be7001d00d0a6f0374322b089c6ea lib/Config/Model/TreeSearcher.pm SHA256 243fdcf5f6ff3b396193349197b9cfda3166e279df4c0166c8696621c49ccd40 lib/Config/Model/TypeConstraints.pm SHA256 bb199a15cfa8bddd7a65aafe47d2c19eace8aaf8eed11ebcd0172b8d2bdf7b44 lib/Config/Model/Utils/GenClassPod.pm SHA256 2b95604120c05052f0ef8aa448135deb51939232a6ba2af1d739d33efda4c5bb lib/Config/Model/Value.pm SHA256 9035067316dd3e2709cc99ce8061b28e5fdf0fe4a5ba811c37bfeeee7abe0741 lib/Config/Model/Value/LayeredInclude.pm SHA256 6495bc550b0000aa29f81ef25750d4afa826970bab150e237e642e0ab5ec22b5 lib/Config/Model/ValueComputer.pm SHA256 c21e1cb1fa695996153fa42557628d5c836a9405c950139e46fcbee3680cd7dd lib/Config/Model/WarpedNode.pm SHA256 87156e4fef2dd28f2c1ef0fc66c7ce1d37b0894fd46eb6260e2112bdd8a4da0b lib/Config/Model/Warper.pm SHA256 1ab37b1af6a7b3163660978bbe38b1d64230aa777e1c96fc2573efde2cf3a6e4 lib/Config/Model/application.d/multistrap SHA256 6c3846297536922ffdc3571b97c1303ed2d07e568f5a11980575d76fbdfa89dc lib/Config/Model/log4perl.conf SHA256 b67e7153fd7d43247e90e7e83aff74baddaf39abf7d522f6a58efba72a45b043 lib/Config/Model/models/Fstab.pl SHA256 f2a8eae38e9220116ef216c7d15cedacf8ac06075079e4366d87d790c269cec2 lib/Config/Model/models/Fstab.pod SHA256 5e241cbca83fc838706a795b033e4c7a9b25ee0aefff29c52cf6c05baee3df2b lib/Config/Model/models/Fstab/CommonOptions.pl SHA256 fbc2354ac2a6d203fe97e0d8259039e8a2a625a9072e6016a20652d5a25d2828 lib/Config/Model/models/Fstab/Ext2FsOpt.pl SHA256 9752b94df108925e938c8d4ea5405cee0e90802e755d2b34c50a2f817268bc9e lib/Config/Model/models/Fstab/Ext3FsOpt.pl SHA256 2f67a7f90d971d195a79f048620e5c122bb4eb18f457af838e3d8e0519f9df22 lib/Config/Model/models/Fstab/Ext4FsOpt.pl SHA256 2c8ccb9f7298c116cc3c72e83e7a5a56ebc76865add430663e3db278742aad37 lib/Config/Model/models/Fstab/FsLine.pl SHA256 9fcd8ba7d59a2f146d79b7a320a6b3d7d16a7390044cb83f85fc29ea462a6c97 lib/Config/Model/models/Fstab/FsLine.pod SHA256 6b3e118565c551ef94bab9dde5d3e26f76863fbc3a9a32cb84460209358a0cee lib/Config/Model/models/Fstab/Iso9660_Opt.pl SHA256 553356a3390a6190b750ed6916fcef100ef9f720c320d57c6b31dae65f272d88 lib/Config/Model/models/Fstab/NoneOptions.pl SHA256 a5669332e42b8493823983bca648ba8d1d7a4088235a2eb4b9f61e80eacf124d lib/Config/Model/models/Fstab/SwapOptions.pl SHA256 1e46115a15c3653e145bed57ecea6fc322b4d33328ee2659147c8e4090c61246 lib/Config/Model/models/Fstab/UsbFsOptions.pl SHA256 b885d95ac2b03ebc1ff893560193f9f1be2b9ef1d844a91be6eb7dd871b9c74c lib/Config/Model/models/Multistrap.pl SHA256 4308ec5f258f0318be8b377b43df36d3c567e5c80b3112f2ae5aea72f436bfc9 lib/Config/Model/models/Multistrap.pod SHA256 e184b390fd61c03a9ca2de9b9b4ce09376e8ccd35dfac782b25921c2df8c675c lib/Config/Model/models/Multistrap/Section.pl SHA256 3ca741c68a15483f7d0eea63b89009c1e39a1661b30759ebb2b2dde7e61f8b4e lib/Config/Model/models/Multistrap/Section.pod SHA256 ebf50aad84af26bd37486a7dc2d1c97a318c25b1c45bfec1b8ab4b9d78dc3310 lib/Config/Model/models/PopCon.pl SHA256 11ebbb09765aa30b62a7b0637f5dfa7e63fd74b44dbbb07dc1de3d3b322d569d lib/Config/Model/models/PopCon.pod SHA256 b4a634f6b4e6647e04fd0ce699c0c6c68ad612fbc39596344379beeb03d0fa4f lib/Config/Model/system.d/fstab SHA256 54a5c6507eb6a85c8ce6da1b702e4c3a0b7303c338ba68f2752194f1fc6b1da2 lib/Config/Model/system.d/popcon SHA256 37b0c1e42f32b65108338d788b851bea3546fc6558cf993603155b214a707bff t/README.md SHA256 afecc64cca7f79dd869dbaeebf75a70ae448420cdad3061d131780ec9fe3dfec t/accept.t SHA256 7c21dd7035ef97522a79ee944d0804a2b2ded40d869e33297132e307d7254efe t/annotation.t SHA256 5547a90151454c02cd529620f4b189b82331dd0720b70b2bd5caa343bf44beb2 t/apply_fix.t SHA256 cf7866d4e8654e7b8e06583d187795e232a9906544e3e6d168e429dc7118791d t/array_id.t SHA256 e7489f0b131e1a52e1bee5ec65aebbc32ad27cc7d24f53719482890a280314e6 t/array_with_data_migration.t SHA256 fb42117a59bd787dd4024b599897ef9fda7b7c5ab19dffbc2f8082e5488b9144 t/augment_class.t SHA256 4f8f467403798775e23cc0780f5451379b5118f853ffaa4259a97933481bd37c t/author-critic.t SHA256 56dbf4f110cd9e79cbe2f888199793ebe57f6b21bc5aa318df82a81359ee197a t/auto_load_model.t SHA256 e95bc0939d98adfef55aab952f02693ffdc1c4e0ffaa86f6ec4a34f598fb1d35 t/backend_ini.t SHA256 b546cd03779f647bf0c95b218c98c2bd07c270e8b68eaa557bea0da1265a304d t/backend_ini_with_section_map.t SHA256 bfda8c1e76be768a0677a478664f4c500ce55afc3f28b40280d21544c1ae59c4 t/backend_mgr.t SHA256 fa9f79d080980550554cc2d7014a3ba74056ac327ba8aac1544a0722712c760d t/backend_multiple.t SHA256 dea0a9253bdb1cfe75cc405de05990a192ae39ee5a1892e2628f44b98e5c92e9 t/backend_plainfile.t SHA256 d3302f629e9c76eaf7473a27a4954379c0877735cd28ffc3738cd9d8b452dcd5 t/check_list.t SHA256 597c27998d763ff5de9c1ef40ed2115e4c4191f53b575bbd78755a63eee4c71c t/check_list_warp.t SHA256 18a72f7fbc520ed6b149447bc3684767e2a105b8513e9051b34fa4ee4451e888 t/cme-force-load.t SHA256 5a44fa296f9a327126ca22d47c1cdb6ee3607da51dcc7a46dd3f34a0dad1d54a t/cme-function.t SHA256 694bcb7504e8916b7e676163236c07242fe8f2784b8caeb624fc3c7fd48f9bce t/describe_node.t SHA256 640109a1259e45c7e9ce012d5eae42c51508b5e6b523417ba0fa409f7a760020 t/dump_as_data.t SHA256 01e53fd8ce2f0c4cedcec6e79369e1418ad360a7d16ad4cc934a03bfbb52c15b t/dump_tree.t SHA256 552f301d3bdbd9b6c6b68e4ad8f5637fd08d3464fd4b03ab9d532a62f9235849 t/fuse_ui.t SHA256 f6851bdce660b6f92c6ddc1f60dc29734fee975377b983bebb149a65130527d9 t/gen-class-doc.t SHA256 3218ab617e74facb26fb3a10eca7912bd22b75787de3b7867cc90ae1db0b8da1 t/get_info.t SHA256 002921bf4714cec36e66b4414ea833f1e985686cde85002d7e6ef02fa6be3fab t/grab.t SHA256 21cc1640b9597688536a03b6e97acc4e0fab19a70f2b775995fcb3f8a68852cd t/hash_id_of_node.t SHA256 3933de86c3e9fab9ade4826a761db39e29e80644bdbe9ada3368fce62330615c t/hash_id_of_values.t SHA256 dfe089c158c7b01dfd0140f2eb57d49b59b73fd398b063b06f67b4c610a90099 t/hash_with_data_migration.t SHA256 6919a3a289be20e150ec57d62c52bea41a52ccb7a0507122983ed31983ae5be5 t/include.t SHA256 291a52ab4f39099902a7990d780d80ab011d3c61ed28bd66a9c95bcdb2601449 t/instance-reset.t SHA256 d2baf0d4f5fe78599f740ea1b3ed802d90f0e6ba3c45c0b4175b5b586e6fe8ee t/instance.t SHA256 33925c3f157806c6cb44c61f049d7aa3e3391bb56dd9953ef0ae51554c453bbd t/iterator.t SHA256 fa93f9e37a39f6695b923d7e1b60132b1774cfed3051b190b7100a70fe88798f t/lib/Config/Model/Backend/Mini.pm SHA256 975a117667e8b291728aed9200742ac74786d438393ab1c2f00edaaee72acc0d t/lib/Config/Model/models/Master.pl SHA256 61f9ccd938e3cb102266bade52cf5684503dad7393eaf2d69aa53b0572549337 t/lib/DummyNode.pm SHA256 8ce73933402c0f0310c3144f3c3c3793b5809f6963f4eed3c742c23c4d7b9b5d t/lib/dump_load_model.pl SHA256 c1402a481412755b8c844afc0f0afc9017736e5491dd2fd92028e35e9abe5dc1 t/lib/load-data.json SHA256 6e4c0400cb1d457f14824adccaf02a0e265dda138fa1ce1e5bf7c2300744a483 t/lib/load-data.yaml SHA256 3b138238b55c377ca3d6057a7d04b05b2756570777fed7de27aa7d26f0b36075 t/lib/test_ini_backend_model.pl SHA256 0404a0e70a9df006330de4786cf967e6418f981274c836bc9a3595c746c19c33 t/load-model.t SHA256 743fea3f1b4ca2b1a871015306869c48f408cac0f2d53135ee8f7aeacf21dca1 t/load.t SHA256 6312ac31357c3176d46f287cdf467f4c7df8bc9ac6444bf6e129fcce2d76940c t/load_model_snippets.t SHA256 87d173397e2a5045af2ca5e4d6149cec292b627f08ce5bbbfb797c29bee85ebf t/loader_logs.t SHA256 fb6c7c4a1491f2987be9c0dec2d1af7d2f734ece1a7d9584ff39dc0d95479532 t/log-init.t SHA256 cbbb4d106ae45c26d3694045c4b0090a9c4dac6fd67d3f45e9023ac46525a7da t/model.t SHA256 a278fe192fce3f63793e9e38edf52622b32a9aab81a31eb099280a0702e73b1b t/model_tests.d/backend-cds-examples/basic SHA256 591f37fcfb67d47e35ac10cfb8d8158bff6db4f63f9cd550451360b1dd3086aa t/model_tests.d/backend-cds-test-conf.pl SHA256 bd34aa677c75ca9826bfdf85d3f32f257a3d56bae74d1005c8d241b731e1d4c4 t/model_tests.d/backend-ini-examples/complex SHA256 6c0a8c73cb2061e403224a8a73c21e62003b24f78fb2856dabddb01de4d2b16a t/model_tests.d/backend-ini-test-conf.pl SHA256 adaca927152974259b670ebc9901e89ff9e361275707227670a323bf3fb40da9 t/model_tests.d/backend-json-examples/basic SHA256 7e5a2a99d1ce48496e1920ee8973b905cfa8f8845fa15e897e5d89a70bd874ac t/model_tests.d/backend-json-test-conf.pl SHA256 8cd716974f130755c6193de897e0be6172b2b86cd7aac238ea8e1631ddd10d25 t/model_tests.d/backend-key-value-examples/bts-control SHA256 361e66ab2d823537b63fc146d84abcc5660b7322a0f836c8e59b810dc63bb9c0 t/model_tests.d/backend-key-value-test-conf.pl SHA256 8495497f0aea2df7075379cc5410d60ef62bc981d7258bb50e2a0736a71a62f3 t/model_tests.d/backend-perl-examples/basic SHA256 37210a1a532198b683d839fd13c3f3962bed94793512aedcd016a5d4628545ce t/model_tests.d/backend-perl-test-conf.pl SHA256 04df930bc5e493b9496193274f27f5cc5690293b09810117f4e483429b684a8d t/model_tests.d/backend-plainfile-examples/with-index/debian/bar.install.list SHA256 04df930bc5e493b9496193274f27f5cc5690293b09810117f4e483429b684a8d t/model_tests.d/backend-plainfile-examples/with-index/debian/bar.move.list SHA256 03be5105a317ac9c2998a1bb9827aad28a16d821cfff729e0cc172769639dbc8 t/model_tests.d/backend-plainfile-examples/with-index/debian/foo.install.list SHA256 bec1f44f650c5a4ffa24299db729ac3a02c7e4ba954af93ea1bb2723e7660415 t/model_tests.d/backend-plainfile-test-conf.pl SHA256 4bf561c14aff2f4301d038e63a64660af884a45d2d2135db0766e3a75d3c7a07 t/model_tests.d/backend-shellvar-examples/debian-719256 SHA256 21faff9d7508208635772b8e04fa010c1dd6ad13fde10532cf4f4568dc386b46 t/model_tests.d/backend-shellvar-examples/keep-order SHA256 4b14fe7c4fbbfa195bc96a5ae32a88b764555870fbf07ab84391d5473c7a1297 t/model_tests.d/backend-shellvar-test-conf.pl SHA256 17efb25bbfcc7f27dcc384609bbc7c067a7a0da56704a081b0bd5d358184f3cf t/model_tests.d/fstab-examples/t0 SHA256 bdf808a6b7dbdca60539ca405f71989667a30099848afed25a8a8db294fd057d t/model_tests.d/fstab-examples/t1 SHA256 45e56290a0e74f207c4d9ee598fc7746dc6c45e3832b0878425046c86088d3bf t/model_tests.d/fstab-test-conf.pl SHA256 72b0f3d560650c9fc65ff4d8dd27144a0bbc396399fc5e9c6de53f8cc108d3de t/model_tests.d/layer-examples/mini/etc/foo-config.pl SHA256 cf2e8516c23cee6613c404477861e7ed9402b2d859271635b4c8b7fc5795cc57 t/model_tests.d/layer-examples/mini/home/joe/foo/config.pl SHA256 43cf05b957ef8aae3b89be9728b11b7baea38233010cba3c3f1bc9d91e57b6a2 t/model_tests.d/layer-test-conf.pl SHA256 8e197759f86effeb039bd12d1903d97e6da8ce34e8fc39c6c29326e310319cd1 t/model_tests.d/multi-ini-examples/max-overflow/etc/bar.conf SHA256 2f24102ab23103b483d02fa5898326d057d525454a150490c7306b1444b07b21 t/model_tests.d/multi-ini-test-conf.pl SHA256 22806fc5e6522d6ff2e87b9574608074160e97219f7b10ebffc8fa5f9a6ddfce t/model_tests.d/multistrap-examples/arm/home/foo/my_arm.conf SHA256 c74f0296fdd58db911af6af2db609ab7365951a175c512ce1f8ec27d07ffaa9b t/model_tests.d/multistrap-examples/arm/usr/share/multistrap/crosschroot.conf SHA256 c74f0296fdd58db911af6af2db609ab7365951a175c512ce1f8ec27d07ffaa9b t/model_tests.d/multistrap-examples/from_scratch/usr/share/multistrap/crosschroot.conf SHA256 2e3d3a8e3da7ac8c25e2640f9f79da5c25b806b4e1b89acc04b660d863570769 t/model_tests.d/multistrap-examples/igep0020/home/foo/strap-igep0020.conf SHA256 12859fe6957da7666466102f9ed8bc2c09b06506f1c2111954d7f5c092fecfac t/model_tests.d/multistrap-examples/igep0020/usr/share/multistrap/arm.conf SHA256 c74f0296fdd58db911af6af2db609ab7365951a175c512ce1f8ec27d07ffaa9b t/model_tests.d/multistrap-examples/igep0020/usr/share/multistrap/crosschroot.conf SHA256 f069d95294fb3158982c20a12fc08ab111d6d7d0809a40f8bafb9710e7529a17 t/model_tests.d/multistrap-examples/igep0020/usr/share/multistrap/squeeze.conf SHA256 c2ee63ed040306e09131a3ca031428a97a2265cf636dec0e81101aad63c8f769 t/model_tests.d/multistrap-test-conf.pl SHA256 633291f3a0bc137d3061dbf2466f0488d6c8cd98066c47127ba97772cdee6013 t/model_tests.d/popcon-examples/t0 SHA256 b3324ec891f23955d3c444c5b1bf31e76085b5253a34c991d36466423909c12f t/model_tests.d/popcon-test-conf.pl SHA256 4a9dc7848645de27e30fbf8d9b554cd6d8c0f450bc0bf57d952d55ac1f282861 t/model_tests.t SHA256 1884e07e8b8dc24932dd5c29cf0cbd88c8272a92e327f0af5e8293cc0fc01cb9 t/multi_warp_object.t SHA256 2936195721a632290102b775074b7f62ff4d933781046908606770cab6b90cdd t/multi_warp_value.t SHA256 91c27d9e179828bb4b53f56e49c9ebc9a9747fe3b67a49d98d6ab40d25468edf t/node-load.t SHA256 5d748490124c9d11a11581ac739a2b15ed752b8ce68f6122a1b6ca6372b9e718 t/node.t SHA256 555ebba5ab2e6a844a3673daad9293684e93a4e0f51b526d6fd2baf0d173e3ed t/node_get_set.t SHA256 23670cf2ae5438c6d3f0b547b356f7dc850de6fc4f12cdc1e3c3dcebe8ba55dc t/obj_tree_scanner.t SHA256 325afe4d3ac4dcf99b3d4bcfa7afe8d0b880412c53c0e161c6c577e4c30e2a2d t/perl-critic.t SHA256 cb27be86ef18c38eb22c8db17bf2fd056fc5d1cf2a97ecc9c5e41cea5ebd2cd2 t/perlcriticrc SHA256 85056ca339b84a901563baa532e2e27c62b0807587988535a27e366783632f39 t/pod.t SHA256 89d673e9d3ec95b3cd654397dd3e9781bbc6247fa2098433cdadb9e65ee77f12 t/pod_generation.t SHA256 66f58a9387e491629aa478c970a8def92f4aefa77f336703adf7462c02074b03 t/recursive_warp_value.t SHA256 f871e1769bb904a940c89a52a84638d6d70b3aef5cf90da7059ccfa8ea48b4a2 t/report.t SHA256 5e8c43360a6788f472c17906890a5ad80f073af0264a48fd2c015c0d6bfab120 t/search_element.t SHA256 1b7a63e6a289530595835555c2353a52fc1dbad3bbda0ba24736646c32e4cd67 t/search_in_tree.t SHA256 a4d4eafff3f72d7964fe665fa35a721466f39ccdb43a397bc3db60d20b14bd9e t/simple_ui.t SHA256 9d62083651b17ddd8051e8d958e93ecaeafa06699a0f37ea4a90d220438eefbc t/smooth_upgrade.t SHA256 74d4c408d78b28434100c3e88de3af099c524049e7f5e3476f9be86a207be576 t/term_ui.t SHA256 e8426a2257cc61d1881d440fd750d1f0718355e304e72c502047efc43fe2be74 t/value.t SHA256 3fcfc71e0892ee240fbdfdb984493dfaa12bd8c948bb6b4b087b1734db31db73 t/value_compute.t SHA256 4da8206b92669a770f4e83f00ab9d583b8aab3412ee58894c6138513cce04ed3 t/value_refer_to.t SHA256 2205bca4852c9d2f0a612826705ef3998e9b0578423572c144549142e98bcb3b t/value_simple_warp.t SHA256 dfc39eeeb22db12b79b13c72f8899f00b2ec8872b103ae720265b67dce44fba4 t/warped_id.t SHA256 3e852223da2990debd84f501ca1cc95ec93cbd22036fea31a7d3f807dd72ef89 t/warped_node.t SHA256 cdf5634a1e10148d433e5bc08fac3d6b0fe3b90e3904e9e47e4c4ee22061a9b0 t/warped_node_collateral.t SHA256 e167d98d880b7a886e63c5b5a0794302228e05fa6ba45ba096155ad46cec0f7b t/warped_value.t SHA256 dc2e6b91767be659e12635d5f3a07055c69d4f57431492be23fc06935414ba6f weaver.ini -----BEGIN PGP SIGNATURE----- iQIzBAEBAwAdFiEEn3I5/LZk8Qsz6dwDwx9P2UmrK2wFAmHgVl8ACgkQwx9P2Umr K2w5yxAAiIkpeqif7p2GXF1thqPf+8asHSiWfUfvql1x2bRitBg+KYYQNfNwHMRe bLTs0ozCw/oEP7tw4r2m4+ImO+25zpC5W5daLb4xBUCJ0k0opfQi3HUmhSskDMFI Le9QXCPfnnMnXbOi5zVCmW2rnFRDJ4kNdEqCWBf2stOFJtoBKYXljoBs4LZoi7f0 3soRSWpswkFtzKY8EbdyrCyB6zGTa7LxNaAqzjBEHBihVdSYofOWpRlIPGdL2LRm rDDxlhGNYe0vv0h7uhEo3kshkqJO8GGS/30VSU4kueyyxfgIj3kjLza786sQ/nEo ehCN1WEi66R/9xdJHLkjXYf3tTbynlqw2n0hF/AJQO89nzlptWMoUNFiEpdsuKEi LF96ZByMsIVYpMdi1vBfwZPkaRPHS2Lyz6ebkiEM2RoEmtI0FzZRzFrcH6+WDW1C r80d2WeN0v02id7CakICWYq+qCMnu/DIHLzfqJpIlEKRosV66URXyPWuASCYr8u0 ZZtkn6LF+3orKjK74BQyD/3mWmmgIhhKB44TE7vldYLiUAJLrFjsjG7HvtRP8faI DIi2JBMSvMNJhFbsLbiYXCZph7kH+C4KeSQGWn+iShvmtbJCBToJmNLbQUPpHBcY IG6sBKthccbVUDn75OZjEZwadqjCINUYHp5Rl10c+2eampycgas= =VNax -----END PGP SIGNATURE----- Config-Model-2.149/TODO0000644000175000017500000000110014170053137013117 0ustar domidomi o [domi] Update compute so that a built-in value can also be computed. This is required to fix a bug is sshd_config where match element values are needlessly written to files o [domi] Filter element according to element in SimpleUI and TERMUI * Rework backends: - obsolete custom backend - move cds backend in C::M::Backend::Any child class - move perl backend in C::M::Backend::Any child class - Use the same backend object to read and write files This need to move most parameters of read/write to object attributes - Migrate file handling to Path::Tiny Config-Model-2.149/Changes0000644000175000017500000037721014170053137013744 0ustar domidomi2.149 2022-01-13 Bug fixes: * fix regression with check_value method 2.148 2022-01-09 Bug fixes: * fix (Exception): keep ref to instance object * fix (Hashid): improve warning message when loading non ordered data * fix (modify instance): show changes before saving 2.147 2021-11-29 Bug fixes: * fix (test): ignore info Log. 2.146 2021-11-28 Model improvements: * fstab: add suid/nosuid (thanks Topi Miettinen) * feat (fstab model): add umask element in common options * feat (fstab model): add description to common options Bug fixes: * feat (Instance): modify methoed displays changes before saving * fix (Loader): typo in .substitute load string command * fix (Grab): improve error message of grab_value * fix (TermUI): add completion to display command * fix (SimpleUI): simplify error message shown to user * fix (SimpleUI): avoid undef warnings * fix (Describe): truncate long lines * fix (Describe): show default value in comments * fix (Describe): show value in user mode * Value: accept on/off as boolean values * fix: test error with perl 5.20 (Closes gh #32) 2.145 2021-11-06 Bug fixes: * fix: compilation error with perl 5.20 to 5.22 * fix (Node): undef warning on $filter value * fix (Model loader): crash with Config::Model::Itself (Debian #998601) 2.144 2021-11-04 Bug fixes: * fix (BackendMgr): try to fix crash on Windows * fix (Constants role): fix crash for perl < 5.28 2.143 2021-10-31 Main change: * requires perl 5.20 Bug fixes: * fix (Model load): fix load from absolute path * fix (BackEndMgr): crash when calling config_file_override with absolute path * fix (get_info): show upstream_default as written in file * feature (get_info): include write_as values 2.142 2021-04-07 New features: * cme function: add force-load parameter to behave like cme command Bug fix: * Avoid messing up array indexes when remove list items (gh #26) Thanks Hugo van der Sanden, James E Keenan and Slaven Rezić for the help * load method: forward value of check parameter 2.141 2021-01-17 New features: * Loader: can extract data from YAML file (requires YAML::Tiny) * Loader: can extract data from JSON file * feature (ini backend): add quote_value parameter Bug fix: * ListId: fix storage of undef value in store_set * Config::Model::Loader: update documentation. (Thanks gregoa) Other changes: * dist.ini: update copyright year 2.140 2020-07-31 API changes: * PlainFile backend: extract get_file_name method * AnyId: add fetch_value and fetch_summary method * Value: add fetch_summary method Bug fix: * fix loader_logs tests broken by Config::Model::Tester 4.006 2.139 2020-07-18 UI changes: * Show warnings in blue color (color can be configured using Log4Perl config file) * shell UI: * add info command * improve tree and ls commands API changes: * Node: add autoadd argument to fetch_element and has_element methods * add get_info method to most tree classes Bug fix: * Exception: drop constraint in parsed_file which avoids a crash when cme should be showing an error message Misc: * cleanup code. Thanks kritika.io for the suggestions * updated copyright years 2.138 2019-12-27 Bug fix: * CheckList: add missing "backend" fetch mode Doc improvements: * Value: update doc of allow_under mode * fix typo in pod doc 2.137 2019-12-01 Bug fixes: * AnyId: avoid deref of undef value * Loader: fix parsing of list assignment with quotes * Value: do not store warnings from computed value * Node: warn only once about deprecated elements * CheckList: accept non_upstream_default mode Doc improvements: * AnyId: clarify doc and error message * Add doc for container method * Value: clarify load_data doc * Value: fix typos in doc API changes: * Value: provide has_warnings along has_warning * DumpAsData, Dumper: * deprecate full_mode parameter * full dump is now mode => user 2.136 2019-07-29 Bug fix: * also tweak ~ dir for tests in Path::Tiny coercion (fixes Config::Model::Systemd tests that was broken with Config::Model 2.134) Doc update: * Mention force option in Instance doc 2.135 2019-06-05 Bug fix: * Fix undef start_node error occuring with 'cme run' command (this regression from previous version broke app-cme tests) * Instance: clear changes after reset Doc update: * remove mention of long gone privilege parameter 2.134 2019-05-05 Bug fix: * Fix Instance->reset_config method * improve error handling of get_model_doc Minor behavior changes: * dump_tree: add quote around value or if that contain '~' Deprecation: * Instance: remove deprecated read_root_dir method Misc: * update copyright year * Tests require Config::Model::Tester 4.002 2.133 2019-01-13 Read/write backend improvements: * Backend::Any: add auto_delete and auto_create * IniFile: delete empty file when auto_delete is set and config file contains no data * warn when restoring backup file 2.132 2018-12-22 Bug fix: * Value: really use old_value to track changes * restore "return undef" in Value.pm to avoid breaking apply_fix Add long forgotten credit (sorry): * add Ylya Arosov to credit 2.131 2018-12-16 With this release, this distribution no longer provides YAML backend. The YAML backend is now delivered in its own distribution. Look for Config::Model::Backend::Yaml on CPAN. Other changes: * Value: use warn_if warn_unless label in warning message shown to user. * BackendMgr: throw correctly "unknown backend" exception * Exception: trap missing object parameter Doc update * remove mention of old config-model-users mailing list (dead) * BackendMgr: mention that Yaml backend is now external 2.130 2018-12-07 Dependency changes: * require boolean module (really) 2.129 2018-12-05 Usability improvements: * Value" improve warning message about multi line value Perl backend improvement: * Convert cme boolean values (i.e. value of value_type boolean) to Perl boolean values Dependency changes: * build require boolean module 2.128 2018-11-21 Usability improvements: * CheckList: die or warn (with cme -force) when storing unknown item in check list. Bad values used to be silently dropped. Test fixes: * add \n at end of yaml test files (gh #22) Internal changes: * improve code quality thanks to the feedbacks provided by kritika.io Doc change: * Improve navigation in doc: move parameters from header line to paragraph. * Instance: add doc for backend_arg * Instance: improve doc of data method 2.127 2018-09-30 Feature improvement: * Can use regexp in leaf model to specify help on values Bug fix: * fix doc of ObjTreeScanner 2.126 2018-08-20 Bug fix: * Value: Don't crash with some chained fixes Usability improvements: * BackendMgr: log an error when eval'ed write dies 2.125 2018-06-24 Bug fix: * BackendMgr: remove close call on fh. This is now handled by Path::Tiny Breaking change: * BackendMgr: remove code to read from stdin. This removes the possibility to read a config file from STDIN. This was deprecated since January and nobody complained. Doc change: * improve pod doc on Grab.pm 2.124 2018-06-09 The main change of this release should help people see what's going on during 'cme run' or 'cme modify'. Config::Model::initialize_log4perl now accepts a verbose parameter to enable verbose message of Loader class (used by cme run and modify). In verbose mode, Loader now shows the effect for each instruction specified on 'cme modify' command line or specified in the script run by 'cme run'. This feature will be available with the next release of cme. Bug fixes: * display USER INFO log as plain message (no need of 'INFO:' prefix) * fix CheckList element handling when cme is run with -force option. (add check param to CheckList) * Value: avoid warning when loading wrong boolean (gh #19) * Avoid unneeded change notif when showing up a node that was previously hidden (gh #17) * improve error message about unknown element (gh #18) 2.123 2018-05-01 On-going improvements of R/W backends: * io_handle backend parameter is deprecated * use file_path in all backends instead of io_handle Test improvements: * build dep on Config::Model::Tester 3.006 * document prove command in t/README.pod * tests run without showing any warnings * all tests accept --log --error --trace parameters * all test models are updated to remove all deprecated declarations Bug fix: * fix parameter sanitisation in Instance * Value: remove self assignment (tx kritika.io) * update WarpedNode synopsis 2.122 2018-04-17 Bug fix: * Warper: fix crash when a warper (aka warp master) is a computed value 2.121 2018-04-15 * BackendMgr: fix handling of file argument * Instance: fix compat with Perl < 5.20 Log improvements: * use User class to log warning for User * Model: add doc for initialize_log4perl * Model: moved log4perl default conf in a separate file (lib/Config/Model/log4perl.conf) Test improvements: * add README for the tests * some tests can be run with --log, --trace and --error options. See t/README.pod for details 2.120 2018-04-08 Bug fix: * fix config file location declared with absolute path (i.e. all system application like ssh, systemd) 2.119 2018-04-02 Main change: * use logger to warn about issues. By default, logged warnings are shown on STDOUT. These warnings can be suppressed using ~/.log4config-model file. API change: * Instance: root_dir parameter can be a Path::Tiny object or a string Bug fixes: * BackendMgr: fix broken file backup * Backend: create dir before creating file * Yaml backend: avoid redefined sub warning 2.118 2018-03-26 On-going backend deprecation: * BackendMgr: deprecate using STDIN to load config file. Which means using '-' with cme '-file' option is deprecated. Backend: * Improve global comment extraction Other changes: * remove unused modules from BackendMgr * Exception: improve Model error message 2.117 2018-02-03 Bug fixes: * notify about addition of hash key only when needed * fix error message of "missing file" exception 2.116 2017-12-15 Fix broken cme: * Instance: fix regression about root_dir param 2.115 2017-12-14 On-going backend deprecation (which might be breaking): * Backend: deprecate using instance name as config file name * All backends: suffix method is deprecated Backend: * ShellVar backend: don't reorder when writing back (experimental) * trap when backend class has no implementation New features: * Loader: provide "english" operator foreach_match, rm rm_value, rm_match, substitute. These are equivalent to :-~ :- :-= :-~ :=~ operators (cme gh#2) Bug fixes: * Node gist: no need to show that value is undef * WarpedNode: forward fetch_gist instead of gist * Instance: add doc for root_path parameter 2.114 2017-11-11 On-going backend deprecation (which might be breaking): * support for multiple backends is now removed. Attempting to configure multiple backend leads to an error message with explanations. * when possible (i.e. when only one backend is specified), translate read_config and write_config in new rw_config. This should limit breakage to the minimum as multiple backends are seldom (if ever) used. New features: * AnyId: add fetch method * CheckList: add store method * Node: add gist parameter and fetch_gist method to get a summary of node content to be shown in user interface. Bug fixes: * Exception: fix call to fetch_element * ObjTreeScanner: Don't try to scan warped out node elements * Instance: no longer show diff-like changes * clean up check on node init (gh #15) * AnyId: add notification triggered by adding a new element to a hash or array. Build changes: * no longer use Text::Diff 2.113 2017-10-12 On-going backend deprecations: * using "custom" backend is now fatal * warn when more than one backend is declared in a model class. This soon will be fatal * udpated models (Fstab Multistrap PopCon) to use new rw_config parameter Bug fixes: * HashId: do not notify when deleting an undef value (Debian #876967) * Value: support file test in code eval done by warn_if and similar tests * remove confusing "master triggered changed" message * really avoid undef warning when homedir is not defined * avoid "unordered data" warning when loading one item in an ordered hash New features usable with 'cme modify' or in a cme script (used by 'cme run'): * add "=.env(...)" instruction to store the content of an environment variable in a value * add "=.file(...)" instruction to store a file in a value. ".file(-)" reads from STDIN. * add a User logger category to log messages to user. Direct calls to warn will be removed to make test output cleaner 2.112 2017-10-01 Fix bugs to make warp mechanism more consistent: * Value: trigger a warp after apply_fix is called * Value: apply replace when warping Other bug fixes: * don't initialise Log4Perl if already done * Avoid warning when YAML data is missing 2.111 2017-09-22 Deprecating features might be necessary, but there's no need to be obnoxious about it: * Reduce the number of legacy warning * use logger mechanism to issue these warnings 2.110 2017-09-21 Unfortunately the deprecations and updates done last release broke Config::Model::Itself. This release fixes these problems: * disable translation of read_config to rw_config * change deprecation messages from warn to say * put back old backend parameters for FsTab, Multistrap and PopCon models 2.109 2017-09-18 Deprecation and updates as announced in http://wp.me/pFBZb-f5 : * the model parameters read_config and write_config that are used to specify different read and write backends are deprecated in favor of rw_config to specify *one* r/w backend * multiple backends are deprecated. * update doc for these deprecations * Dump string backend (cds_file) is now handled by its own class (Config::Model::Backend::CdsFile) * Perl backend (perl_file) is now handled by its own class (Config::Model::Backend::PerlFile) * Model: die when model parameters allow, allow_from, follow are used. These parameters were deprecated several years ago. Other changes: * update backend parameters of FsTab, Multistrap, PopCon models * Value: allow regexp and code test for enum (like warn_if_match) Test improvements * can run tests concurrently: prove -j8 runs all tests in 4s (16s without -j8) 2.108 2017-08-31 Fix random failure in non-regression tests 2.107 2017-08-30 Deprecation: read/write backends have many complex features to read and write configuration files that are not used. This is the first step to deprecate and remove these features: * custom backends are deprecated * add doc that show how to replace a custom backend with a backend based on Config::Model::Backend::Any Security improvements: * ValueComputer: safer use of variables in eval: variables are passed to the eval'ed code in a hash insted of being inserted *in* the code to eval. Bug fixes: * value: fix mechanism to avoid repetitive warnings (Thanks Tincho) * use check => skip when fetching a value from is_element_available method. This avoid missing warnings when is_element_available function triggers a read of a configuration file (like debian/control) 2.106 2017-07-16 Doc updates: * BackendMgr: update doc of config_file_name Improvement on error behavior: * Fix message of WrongType Exception * die if model line is missing from application file * ensure that an application file is not parsed twice * avoid undef warning when homedir is not defined * cme function: improve error msg for unknown application 2.105 2017-06-09 Bug fixes: * Value: fix fetch in non_upstream_default mode to avoid breaking 'cme meta plugin' command 2.104 2017-06-03 Improvements: * Instance: add backend_arg to enable misc parameter for cme command (e.g a systemd service name for systemd model or a patch name for Dpkg patch model). (Build require Config::Model::Tester 2.062) Bug fixes: * BackendMgr: * allow empty but defined config_dir * ignore config_file in non-root node (do not die anymore) * Plainfile backend: try to fix a windows bug showing up on smoke tests * Dumper: * hash id containing @ must be quoted * accept non_upstream_default mode * Value: fix fetch in non_upstream_default mode 2.103 2017-05-25 Bug fix release: * dist.ini: put back YAML build dep which is used for tests * remove debug trace about YAML class * fix exception message to show any kind of data. 2.102 2017-05-14 Fix security issues: * do not rely on '.' in @INC to load snippet model files (CVE-2017-0374) * genclasspod: remove use lib (CVE-2017-0373) * avoid possible creation of Perl object through hostile YAML file: use YAML::Tiny in YAML backend instead of YAML::Any Model improvement * model can choose YAML parser (default YAML::Tiny) Bug fix: * boolean value: accept empty string as false value 2.101 2017-04-28 Model improvement: * Add assign_char and assign_with to IniFile backend. So it can be used for files with "key: value" lines. * add option to write hash key with empty values. By default empty hash values are dropped and the hash keys of these values are lost. Usability improvement: * Value: if possible show why a fix is applied, i.e. show the warning that triggered the fix * improved log levels (i.e. move some log from debug to info or trace) Improvement: * Model: add log_level parameter, so logs can be shown with a cme command line option * prevent undef warnings on Windows Deprecation warning: * Model: warn in case of undef constructor argument 2.100 2017-03-18 Usability improvement: * Unknown element excetption show instructions to report a bug. Improvement of doc generated from model: * add compute information in generated doc * pod generator: show default values in item list Bug fix: * Fix file mode test (fix CPAN smoke tests) 2.099 2017-03-05 Model improvement: * add file_mode parameter to backend specification. This parameter sets the permission (mode) of written configuration files (need Config::Model::Tester 2.059 to test) 2.098 2017-02-26 This release bring some improvements to enable more feature on Debian Dpkg model. Build: * build depends on Config::Model::Tester 2.059 * bump © year in dist.ini Model improvements: * allow injection of model snippet in another configuration class. This is used by dpkg model: a dpkg-control default value is computed from a value in dpkg model only when dpkg-control model is loaded with dpkg model, * add doc for has_instance and get_instance methods Plainfile backend improvements: * handle deletion of file managed by Plainfile backend * plainfile backend can handle file named with &element and &index functions, i.e the config file name can depend on the location of the value in the configuration tree. (used by dpkg model for debian/.install files) Value computer improvements: * doc: mention that functions are allowed in variable definition * allow '- -' or '--' param to &index Bug fix: * fix error forwarding in BackendMgr * warn when Term::ReadLine::Gnu is not installed * fix term UI set command to accept white spaces * Loader: allow creation of empty hash leaf 2.097 2016-12-22 Bug fix: * fix a regression seen when starting curses interface (fix retrieval of an instance using an instance name) 2.096 2016-12-11 Term UI improvement * fix autocompletion of 'cd' command * add -nz and -v option to ll command * ll command accept several patterns * improved ll output Bug fix: * show complete stack trace of rethrown exceptions * Node: propagate check param when calling init (which fix cme's -force option) Build: * dist.ini Add missing prereq 'parent' as plugin [AutoPrereqs] missed it (Mohammad S Anwar++) * new dependencies: List::Util Regexp::Common 2.095 2016-12-06 New feature usable by cme: * loader: add .insort() command for hash element * Hash element: add insort method Term UI improvement * better format the output of 'desc' command (transform pod doc to text). This requires Pod::Text and Pod::Simple 3.23 Bug fix: * track and save annotation changes (gh #12) * Node: propagate check override in init() (which fixes loading of a systemd config that contains an error) 2.094 2016-11-09 Fix compatibility with older Term::ReadLine::Gnu: * TermUI: skip call to enableUTF8 if not available (gh #11) 2.093 2016-11-08 Hygiene: * Add Travis CI file (Thanks Jose Luis Perez Diez) New feature in read/write backend: * Allow alternate comment char in INI config file (gh #10) required to support Systemd config files Bug fix: * Better support of utf8 in term UI 2.092 2016-09-23 * New feature in shell UI: * 'll' command shows a warning sign when an element has a warning that may be fixed * added 'check' command * 'fix' command can be applied to selected element instead on the whole config. Other bug fixes: * Node: fix deep_check propagation * Iterator triggers a call_back if a hash element has a warning (required to fix the wizard of the graphical interface which did not stop on a hash element when needed) 2.091 2016-09-13 Bug fix: * really fix issue with '.' removal from @INC (needed to close Debian #837682) 2.090 2016-09-10 New feature: * Model developer can use $std_value in warning messages tp provide better feedback to user. This variable is substituted with preset, computed or default value when the message is generated. Cleanup: * remove obsolete skip_read parameter (breaks App::Cme older than v1.011) Bug fix: * Add double quote when dumping value that contain '#' * Value: generates same error messages for warn_if, warn_if_match * fix other collaterals of '.' removal from @INC 2.089 2016-09-04 New feature: Now 3 types of check can be used on hash or array elements: content check, id check (as usual) and deep_check (should be used to check between if value and other part of config tree). Only the index check is run whenever an element of the hash/array is read. The other are used when check() or apply_fixes methods are called. Documentation: * converted README.pod to markdown Bug fix: * load perl data file even if @INC does not contain '.' (required for perl 5.14 or Debian perl 5.22.2-4) * Loader: trap another syntax error in load steps. This may breaks existing tests or cme scripts that contain such an error. 2.088 2016-07-09 Documentation improvements: * document repo structure in CONTRIBUTE file * document Instance application method * add auto_delete param in pod doc * add CREDITS section in main doc New instructions for 'cme modify' (in Config::Model::Loader): * add copy command for list * add clear command for list and hash Bug fix: * use sort keys to get consistent warning order (which is important for non-regression tests) * fix regexps for Perl 5.22 (gh #6) Tx mat813 2.087 2016-06-29 A release with mostly documentation improvements: * Fixed many grammatical issues in all pod docs * Added CONTRIBUTE.md * Instance doc: * separate data change methods from internal methods * specify value returned by load() Model specification change * move warp info in warp param in WarpedNode. The change is backward compatible and will show a notification on STDOUT. This notification will become later a warning. * always show a message when using some parameters that were deprecated in 2007. This may break tests. It's time to fix them. Bug fixes: * add as_string method to all exception classes * BackendMgr: correctly handle Path::Tiny exceptions * Value: show changes of boolean values as they are written in configuration file 2.086 2016-06-04 Fixed some bugs so that cme() works with new Systemd model: * cme() uses config_dir from app file * Node: element_type works on not yet accepted element * Node: improved doc of accept_element() 2.085 2016-05-29 The new releases brings new functions to simplify script that modify configuration files. For instance, the following line is enough to update popcon's configuration file: cme('popcon')->modify("PARTICIPATE=yes"); In more details: * Config::Model provides a 'cme' exported function (see also the SYNOPSIS of Config::Model doc) * Instance: added modify and save() methods Other changes: * Term::ReadLine is not required for build or tests * Instance skip_read parameter is deprecated 2.084 2016-05-26 Doc updates: * Model doc: * use cme meta instead of config-model-edit * removed Log4Perl init for synopsis.. * improved instance method doc * removed obsolete (and broken) example directory * Instance: clarified constructor doc Dependencies changes: * TermUI is now optional (like FuseUI). So Term::ReadLine dependency is now recommended instead of required. Bug fixes: * Fix gen_class_pod which skipped some classes (fix reproducible build of libconfig-model-openssh-perl) * Model: instance() accepts application param * Removed FATAL warnings from Instance * all tree elements: added has_data method * read model files (and doc) as utf8 2.083 2016-04-20 Functional improvements: * backend parameters: added auto_delete parameter so that a config file can be removed when it no longer contains data * attributes specified in a model plugin can override attributes of the base model. Bug fixes: * BackendMgr: do not remove links to config files * Fix ini backend to parse values that contain '=' Doc updates: * Improved instructions to specify a backend in Config::Model::BackendMgr doc * Added instructions to create your own backend in Config::Model::Backend::Any doc * updated model creation intro doc * Mentions Itself generated doc as reference doc * update CreateModelFromDoc to use cme meta edit 2.082 2016-03-29 No big change this time, but a lot of small improvements required by the systemd model I'm working on... Functional improvements: * Loader: list operator :~ with no argument loops over all values of a hash element * DumpAsData: also accepts 'mode' param like fetch from Config::Model::Value Bug fixes: * Fix tests broken by C::M::Tester 2.053 (required) * Loader: fix loop bug which exited too soon * Improve hash dump readability ... * DumpAsData: Fix corrupted output... * BackendMgr: always translate dir with ~/ Doc updates: * removed Log4Perl instructions from synopsis. Log4Perl initialisation is handled by Config::Model constructor since v2.057 * Improved C::M::Warper and C::M:Lister docs 2.081 2016-02-29 Bug fixes: * Fix error handling in Value. This should fix freebsd smoke tests. The weird thing is that these tests should have failed in all arch... 2.080 2016-02-27 Functional improvements: * storing a wrong value is no longer ignored but now triggers an exception. Other bug fixes: * Trigger change notif when store_set reduces the nb of items (closes gh #4) * Improved change message shown to user * Value: don't display grammar in case of error 2.079 2016-02-12 YAML backend changes: * Remove YAML file when no data is left * When a root class has only one element, the backend write (and read) only the content of that element (this reduce the depth of the written data structure by one). Functional improvements: * Added "ChangeTracker" log class and traces (Log::Log4Perl) * HashId: load_data can load ordered data in non-ordered hash Bug fixes: * Removed Exception::Class from warper error handler (gh #5, Thanks jplesnik) * Dumper/Loader: handle literal \\n 2.078 2016-01-24 A cleanup (and breaking) release: Error handling no longer uses Exception::Class. Config::Model::Exception was re-written to emulate most of Exception::Class behavior. This will break modules which traps or throw exceptions using Exception::Class (at least Config::Model::CursesUI will break). * Config::Model: fix get_element_property (fix a bug with cme dpkg where XS-Autobuild is wrongly added to debian/control file) * Config::Model::Value: * don't check value when loading layered config (aka system default values). These values are assumed to be correct. * accept when a mandatory value is set by a layered value. (this fixes hangs in Config::Model::Itself tests) 2.077 2016-01-20 New features: * Loader: added hash copy command. This new command can be used with something like: "cme modify stuff some_hash:.copy(from,to)" * Instance: added config_dir (used when provided by application info and not by model) Bug fix: * ValueComputer: escape variables containing a quote (Debian #810768) * Value: fix check of reference values 2.076 2016-01-14 One major feature of Config::Model is the possibility to change the structure of the tree depending on a configuration paramater value. This "warp" feature is used in lcdproc model: when a driver is choosen by user, the configuration parameter of this driver are shown and parameters for other drivers are hidden. Up to now, only one driver could be selected at a time because the warp mechanism could be driven only by a leaf value. Now this warp feature can be driven by a check list. So lcdproc model can now select more that one driver at a time. Other functionality improvements: * Ini backend: doc mentions "IniFile" instead of ini_file to match Config::Model::Backend::IniFile class name. * IniFile backend can read/write check list 2.075 2015-11-22 Functionality improvements: * Lister: can list local (dev) application Support: * changed bugtracker to github's 2.074 2015-09-30 Functionality improvements: * Loader: added navigation with upward search. E.g. with a command like '/foo', the loader will go up the tree until a node containing a 'foo' element is found. * C::M::Node: added backend_support_annotation method. This will ne used by the Tk GUI to decide whether to display a widget to edit annotation (aka comments) Doc improvements: * Backend::Any: added missing doc about method that can or must be overloaded by a read/write backend. 2.073 2015-07-19 Bug fix: * Fix typo in module name loaded in tests that led to impossible build requirement (RT #105938) 2.072 2015-07-18 Functionality improvements: * Loader: convert literal "\n" into real \n * shell UI: added 'tree' command to show config tree from current node Improvement of messages shown to user: * Node: Warn if an accepted element is likely a typo (Debian #789568) (this feature requires recommended module Text::Levenshtein::Damerau to be installed) * All: improved location_short output (truncates long path with '[...]' instead of '[truncated...]') * All: improved change summary message Documentation improvements: * Loader: Added examples using cme modify in pod doc * AnyThing: Added missing doc for location_short and composite_name_short * Updated wordpress link to use config-model tag Cruft cleanup: * removed cme-old command 2.071 2015-05-23 Bug and doc fix release: * shell like user interface: * fixed completion of commands (like set, clear...) * improved error message sent when command is wrong * use item location as prompt * Loader: fixed parding of command like foo:.insort("bar( stuff )") which are also used in shell UI. * Backend::Any: mention cme command used to edit config file in comment header when writing back files. (e.g. "You can run 'cme edit lcdproc' to modify this file" is written in header of /etc/LCDd.conf) * Value: fixed formatting and errors in pod doc 2.070 2015-05-03 Added minor features and bug fixes: * Model: + added include_backend model parameter for xorg * include no longer include read/write spec... (Debian #783952) * Hash and Array: clear now triggers notify_change * Value: boolean conversion (e.g yes/no to 1/0) during initial load must not trigger a change notification... * shell UI: + added fix command * added clear command for list hash and value... 2.069 2015-04-25 * Model: Allow inclusion of read/write specification 2.068 2015-03-29 Small improvements: * Value: request configuration save when initial load detects problem like duplicated or mismatched values in config file * Loader: raise an exception when ':' action is used with a value element New features: * C::M::Anything::grab: type param can also be an array ref * Instance: added 'update' method 2.067 2015-03-01 Bug fix release: * SimpleUI: fix 'll' command (failed without argument) * C::M::Backend::Any: + added show_message method (delegated to node) * added missing doc for node attribute * C::M::Instance: callback attributes are now rw (should fix test failures of Config::Model::Itself) * C::M::AnyThing: delegates show_message to instance 2.066 2015-02-15 * C::M::Instance: + added on_message_cb and show_message parameters * C::M::GenClassPod: * added missing doc for gen_class_pod parameters * generate doc in a reproducible way by using "sort keys". This should fix Debian problem with unreproducible build found on libconfig-model-dpkg-perl and libconfig-model-itself-perl * dist.ini: use free.fr address instead of cpan.org to avoid problems with automated release e-mail 2.065 2015-01-06 Bug fixes: * Value: avoid undef warning when creating error message * Node: Must load override class to be able to use it... New (small) feature: * Value: warning or error message defined in a model can contain a $_ to show the bad value to user 2.064 2014-12-04 A small change for this release: * Version 2.062 added the possibility to override the Perl class implementing a configuration node by adding a class parameter in a place that is confusing. This release fix this bug: this optional override class is now declared at the top of a configuration class. 2.063 2014-11-28 Bug fix release: * GenClassPod: use Exporter instead of Exporter::Lite. * adapted contrib/bash_completion for cme-old 2.062 2014-11-23 Big change for this release: * cme command is no longer delivered with this distribution. cme is now delivered by App::Cme distribution. To help the transition, this distribution delivers cme-old. You can use this command until App::Cme is available in CPAN (next few days) or if you find bugs in the new cme command (which now uses App::Cmd). Other incompatible changes: * old config-edit command is now really gone * cme extensions are obsolete. Extension mechanism is now provided by App::Cmd New feature: * The Perl class used to implement node, list and hash configuration element can be overridden using a new 'class' parameter. The Perl class passed to this parameter must inherit Config::Model::Node, or Config::Model::HashId or Config::Model::ListId. Bug fixes: * Value: skip notification if migrate yields an empty value * Model: use logger for tracing legacy translation 2.061 2014-09-23 Bug fix release: * ValueComputer: leave $@ and $! alone in formula. Also skip variables like '$ foo' 2.060 2014-08-19 Bug fix release: * value.t: avoid smoke test failures * Avoid new perl 5.20 warning (Debian #758320) * Value: improved notify change message (computed vs preset vs default) * fix pod doc in cme (RT 97605, Debian #756433) * depends directly on YAML, not YAML::Any which will be deprecated 2.059 2014-06-29 New features: * cme: + added shell command as a shortcut to 'cme edit -ui shell'. E.g 'cme shell ssh' to edit ssh_config through a shell like UI + add :@ and :.sort sub command for ordered hash. E.g.: "cme modify dpkg-control ~~ 'binary:~/.*/ Depends:.sort' -save" or "cme modify dpkg-copyright ~~ 'Files:.sort' -save " * Config::Model::Value: added warn_if parameter Bug fixes: * cme shell mode: * fix or add completion for several commands * added shell style pattern match to ll and ls command (e.g 'ls foo*') * remove version req from use YAML::Any 0.303 (resolve issues with Debian FTBS) * Value: fix crash when default value raises a warning and code fix returns undef. 2.058 2014-06-19 Bug fix release * cme: modify cryptic user message about "Fixing stuff" * Value: tweak migrate_value to always return something, even undef. This fixes 'cme check dpkg-copyright' crash (thanks gregoa) * Loader: fix pod doc about list operators * AnyThing: avoid undef warning that breaks test on freebsd perl 5.10.1 2.057 2014-06-12 New features: * Config::Model: initialise log4perl during construction * Value: added file and dir value type. A warning is issued when file or dir is not found. Other bug fixes: * Shortens long index to limit the length of warning and error messages * Value: fix check done during apply_fixes... * ObjTreeScanner: tolerate deprecated experience parameter. 2.056 2014-05-18 This release deprecates experience associated with configuration element. experience specification in models is now ignored. Other Changes: * added bash_completion snippet associated to a model. This will be useful for dpkg-patch model * C::M::Lister: skip backup files when listing available applications * replace File::Slurp with Path::Tiny in yaml backend test and gen-class-pod (RT #95692). (which changes the dependencies) * replaced Path::Class with Path::Tiny dependency 2.055 2014-05-02 This release removes all code related to asynchronous stores. This code was buggy. Making this work correctly would require re-writing most of Config::Model. * Config::Model::Value: * added deprecation warning about callback parameter * C::M::Value: removed async code * perltidy run on all files * removed dependency on namepace::autoclean * Removed AnyEvent dependency 2.054 2014-04-01 Bug fix release: * Loader Dumper: fix quote handling (Closes Debian 743097) * Loader: return 'ok' after dispatching an action (avoid undef warning during tests) * cme: -save options force a save even if no semantic change was done * ListId: sort may trigger notify_change is elements are actually moved around, so 'cme modify stuff list:.sort' will save the file as expected. 2.053 2014-03-25 Bug fix release: * Loader: fix broken list leaf assignment (like 'list:4=foo') 2.052 2014-03-23 This release provides new functionalities to 'cme modify stuff' and to the shell like interface ('cme edit -ui shell stuff). See Config::Model::Loader doc for details: + added remove by value on list and hash ( :-= and :-~ ) (Closes Debian #741453) + added lots of list and hash operator usable on 'cme modify stuff'. E.g. :.insort :.insert_before :.insert_at :.unshift :.push :.sort + handle list/hash value substitution ( e.g. list:=~s/foo/bar/ ) * warn when trying to remove a list element with a non numeric index * rationalize list and hash commands: list assignment is now list:=a,b,c instead of list=a,b,c Other changes: * Dumper: use new syntax when dumping a list of value (i.e. list:=a,b,c) * Instance: don't print change if old and new value are undef 2.051 2014-03-06 * cme: fix command like "cme modify foo ~~ " * ValueComputer: formula with eval no longer mess with $& and ${^MATCH} variables used in regexp 2.050 2014-02-27 * Restore NAME section in Config::Model::Manual::* man pages 2.049 2014-02-26 Bug fix and minor new feature release: * C::M::AnyThing: added has_warning fallback method (always return 0) (RT 93329) * C::M::Anything: added clear_annotation method 2.048 2014-02-23 The main changes of this release are the new features of cme command: * add possibility to override config file (for appli with allow_config_file_override) (part of Debian #739387) if config file override is '-', open STDIN to read and STDOUT to write. This way, cme can be used as a filter. * added -strict option so cme exits 1 when warnings are found (Closes Debian #736972) * added -save option to force save. Useful when just reformatting is desired * modify command can apply Perl substitution (s/foo/bar) to configuration values Other changes: * C::M::Loader: * changed hash selection =~ sub-command to :~ + added =~ subcommand to apply Perl substitution to values * Config::Model: load EV at compile time (Debian #738975) * C::M::Value: limit the number of re-try when applying fix to avoid deep recursion errors * C::M::Node: force a save when reading a deprecated parameter (RT 92639) * C::M::Instance: use msg parameter when listing changes * C::M::AnyThing: added doc for notify_change 2.047 2014-01-25 * Value: store a good value cancels the error stored in Instance * Term UI: * list unsaved changes and propose to save on exit or quit * fixed "save" command * added 'changes' command to list unsaved changes * allow also delete command on leaf element * added reset command to set a leaf element to undef * allow spaces around '=' and ':' * tweak cme-gen-class-pod so it can be run without cme (handy for tests) * Model generate_doc: write file if new doc is different from old (don't try to be smart with timestamps) 2.046 2013-12-15 * cme: + added -create option to force creation of missing configuration file * improved message about applied changes and don't show '0' as * added examples in pod doc * BackendMgr: + add note about cme in header of saved file (if comments are supported in the configuration file format) * Improved error message when no config file is found * skip backup copy if no original file is found * Node: avoid unknown element failure when check is 'no' * ValueComputer: * added note in doc about compute variable usage * correctly handles &index(-x) where x is a number > 1 * improved error message if 'follow' parameter does not point to a leaf in configuration tree * overdue doc changes: s/WarpedThing/Warper/g in pod docs 2.045 2013-10-18 * Manually restored dep on MouseX::NativeTraits * bumped dep on Config::Model::Tester to 2.046 * cme: print an error message when no application is specified (Closes Debian #726447) 2.044 2013-10-13 The main change of this release is the addition of a JSON backend so that cme can read and write JSON configuration files. Given that JSON is more and more used, this new backend is bound to be useful. Other fixes: * cme: * force write back if -force option is used * updated doc 2.043 2013-09-20 * build depends on Config::Model::Tester 2.046 to avoid dependency issues * Value: accept yes/no true/false as default value for Boolean. This can make model declaration more consistent when boolean value must be written as true/false, yes/no. In this case, forcing model developer to write default value as 0/1 was not cool and prevented generation of model like LcdProc's model. 2.042 2013-09-15 * Config::Model: load AnyEvent as soon as possible to avoid test issues * ListId: fix typos in pod doc * scripts: use /usr/bin/env to be more portable (e.g. for Mac OSX) 2.041 2013-08-14 Main changes for this release are: * The ENCRYPT parameter of Popularity contest model was changed from boolean type to a yes,maybe,no value, thus allowing a "réponse de Normand" ;) This follows up resolution of Debian bug #714917. * Config::Model::Tester class was moved in its own distribution. Hence this distribution now build depends on Config::Model::Tester Other bug fixes: * Avoid warning with 'cme list' (Closes Debian #719197) * ShellVar backend: Allow variable assignement like "foo = value". This is not legal is Shell but sometimes used in configuration files using a shell like syntax (Closes Debian #719256) Other changes: * Removed build-dep on File::Copy::Recursive 2.040 2013-07-20 * Fix '~' in path substitution in BackendMgr * Skip cme command test on non unix-like systems 2.039 2013-07-18 Framework changes: * CheckList: + Added clear_item and clear_layered methods + added user mode to retrieve data * clear now reset (undefs) a check-list instead of setting items to 0 * load_data accepts hash ref * get_check_list_as_hash: added user mode, don't return 0 for undef items * set_checked_list_as_hash: Missing items in the given list of parameters are now reset * Added dependency on Module::Runtime to avoid test failure on Mac and Windows Backends: * BackendAny: lack of suffix method is now an info not a warning * BackendMgr: + added $home override for tests + added default_layer backend parameter + added os_config_dir parameter - die if obsolete read_config_dir or write_config_dir is specified Test framework: * Tester: + allow override of home directory for tests + can also use $model for internal tests * check test item now accepts array refs Doc: * added log config file in contrib 2.038 2013-07-03 Framework changes: * cme: added -backup option. Application changes: * popcon model: * replace yes/no enum value with boolean written as yes/no + added ENCRYPT support Backends: * all: don't loose part of comment when '#' is embedded in comment * Ini backend: handle storage to non available element by ditching data 2.037 2013-06-15 Framework changes: * renamed ChangeLog in Changes to conform to Perl standards * added missing dep on File::Slurp * cme: added -try-app-as-model option (experimental) * Most pod docs: Replaced obsolete links to Config::Model::AutoRead with Config::Model::BackendMgr Application changes: * Removed LcdProc model (now in its own Perl distribution) 2.036 2013-05-25 Framework changes: * config-edit: added deprecation warning * Value: * fix pod doc error in L<> which tripped smoke tests * apply_fixes: check after fix must be asynchronous * Node::load_data: use a predictable order to accept elements. This change fixes the smoke test error in t/backend_ini.t (Closes Debian #709785) Test changes: * make t/pod.t run only when AUTHOR_TESTING is set (Closes RT 8533 and Debian #709784) 2.035 2013-04-27 * Node has_element: small optimisation for common case * cme: * make sure that async store is used before actual check * load Tk only when using edit command (avoids issues on exit with AnyEvent) 2.034 2013-04-17 * Model: fix generation of model doc that broke with 2.032 2.033 2013-04-15 * Model: load returns loaded class in the correct order. Otherwise Config::Model::Itself will write back config classes in a random order (for files declaring more than one class) 2.032 2013-04-15 Framework Changes: * Model: completely re-organized the way a model is loaded to be able to add model extensions to an included class * Doc: clarified and moved model plugin doc in advanced manual * config-edit: added deprecation warning in Synopsis Application changes: * Fstab model: added missing relatime option 2.031 2013-04-03 Framework Changes: * All: use directly Mouse instead of going through Any::Moose (which is deprecated) * Removed dependency on Any::Moose 2.030 2013-03-23 Framework Changes: * Value: fix reset value for mandatory with default value * Node load_data: added kludge to avoid breaking C::M::Itself Application changes: * LCDproc model generator: Added a more special treatment for Hello and GoodBye parameters to cope with new INI backend (which is more strict than previous versions) 01 2013-02-27 The main change of this release is to provide asynchronous store check. Now, a model can check the validity of a configuration value against a remote resource in a non-blocking way. This is currently used by Dpkg model to check the validity of package names with Debian server through several concurent http requests. This change is backward compatible except for Value store method: it returns now 1 instead of the stored value. OTOH, that feature was not documented. Classes inheriting Config::Model::Value may be impacted, although old version of Config::Model::Dpkg::Dependency is still working. In more details... Framework Changes: * Instance: * propagate check parameter to root node * store path of tree items having an error condition * ListId: * changed load_data signature to accept named parameters * load_data accepts hash_ref and store them in the first element * Value: * croak if notify_change is called for nothing * make sure that all fixes are applied * limit the number of times a fix can be tried * store always returns 1 Backend changes: * rewrote INI parser so that check is enabled directly on store Test Changes: * fixed multistrap tests * test ini backend: test split_reg parameter 2.029 2012-11-28 * cme-gen-class-pod: pod doc can be generated from a class specified on command line argument (really this time, previous version was broken) * cme: run the first extension found in @INC, not the last one 2.028 2012-11-27 * cme: + added a BUGS section in man page * Improved error message for unknown elements * cme-gen-class-pod: pod doc can be generated from a class specified on command line argument * fix test that broke with perl 5.17 * removed unneeded 'use UNIVERSAL'. (should fix smoke tests) 2.027 2012-10-30 * fix checklist problem with writing default values (which broke openssh demo). (Closes: Debian #691338) * Dumper: fix wrong module reference in pod doc 2.026 2012-09-27 * Re-released 2.026_2 as good to go. 02 2012-09-20 * Added build-time dep on YAML::Any 01 2012-09-20 * Application changes: * IMPORTANT: Debian Dpkg model was removed. It will be available on Debian soon as a native package. It will also be published on CPAN in Config::Model::Dpkg. * Framework changes: * cme: added possibility to run extensions. The first extension is gen-class-pod. I.e. you can run 'cme gen-class-pod' (which is useful only if you develop a configuration model...) 2.025 2012-09-10 * Test: Fix fuseui test regression that shows on non-linux systems 2.024 2012-09-04 * Debian dpkg dependency: * Warn and can remove unversioned dependency on essential package (Debian bug 684208) * Warn and replace perl-modules dependency with perl * Don't mess with alternate dependency with < relation (Closes Debian #682730) * remove Debian epoch when checking perl module version from corelist (Debian bug # 683861) * Framework changes: * Lister: use @INC to get available application models. This is mostly useful to use local models for tests * cme command changes: * added bash completion for 'fix' subcommand * fix pod doc (gregoa) * improved notification change (avoid duplication and added a clear message for swap) * cme: added -dir-char option for fusefs command 2.023 2012-07-04 * Application changes: * Debian dpkg control binary: * In control binary Depends, replace 'perl' dep with ${perl:Depends} This is implemented as a warning and is changed only if apply_fix is called. Duplicates ${perl:Depends} will also be removed by apply_fix. 2.022 2012-07-03 * Application changes: * Debian::Dpkg * fix a race condition between the various calls to Debian's madison site * Framework changes: * added -from and -filter option to cme fix command 2.021 2012-06-28 * Application changes: * Debian::Dpkg * Bump default compat level to 9 (for hardening) * dependency model: * Make concurrent calls to madison to reduce user wait with AnyEvent::HTTP * make sure that apply_fix trigger notification changes so the fixes are indeed saved when running apply_fix (thanks to gregoa for the heads up) * copyright: allow any non-space character for license short name * Framework changes: - Removed dependency on LWP::Simple + Added dependency on AnyEvent and AnyEvent::HTTP * cme: clean up the mess after AnyEvent headbutts Tk :-/ 2.020 2012-06-18 * Application changes: * Fix DEP-3 model: + added missing parameters (Subject ...) + accept Bug-* parameters * Better cope with unstructured text after Subject keyword * Framework changes: * prepare release. depends on List::MoreUtils * fix cme doc example (Closes Debian: #677069) * Node: accept stuff: added 'accept_after' parameter * Tester framework: * force write_back during tests 2.019 2012-06-05 * Framework changes: + doc generated from model now provides details on status (e.g. deprecation) and migration (HEAD, master) * check_list: make sure that apply_fixes can be called on check_list even though it does nothing there 2.018 2012-05-29 * Application changes: + Debian::Dependency: Added a check and fix for debhelper version requirement taking into account compat value. This check is available only with full dpkg model (i.e. "cme xxx dpkg" command). It is disabled when using only dpkg-contol model ("cme xxx dpkg-control"). * Debian::Dpkg model: fix default Vcs-Git URL for debian-perl packages * Framework changes: * Value: * avoid issuing the same warning twice * send a notif warning only when default data is different from current data as already seen by user (i.e. // ) * cme: better formatting when printing changes * WarpedNode: Don't call notify_change when not needed. * added a note parameter for notify_change * Instance: initial_load default value is now 0. * Node: correctly set initial_load mode when init is called recursively 2.017 2012-05-21 * Framework changes: * Fix missing YAML dependency in configure require 2.016 2012-05-20 * Framework changes: * Having dependencies in prereq does not mean they are listed in runtime require. The dependency list is now duplicated to have them in prereq (for smoke tests) and runtime require. This should help smoke tests for modules depending on Config::Model * Fixed small doc mistake in Tester 2.015 2012-05-14 * Application changes: * Copyright model: replace migrate_keys_from with new migrate_values_from. This simplifies the model * Framework changes: + List or Hash: added migrate_values_from to enable migration from another hash or list. migrate_keys_from for list element is now deprecated. * List, Hash, Value: ensure that migration is done after initial load, i.e. once all data from configuration file is loaded. * AnyId, List, Hash: deprecated get_all_indexes in favor of fetch_all_indexes * Value: * make sure that setting a default value triggers notify_change so the resulting modification in the config file can be saved * don't trigger notify_change with update undef -> undef * Test changes: * Tester: added file_contents_like and file_contents_unlike tests 2.014 2012-05-03 * Application changes: * cme: list changes before saving data (unless save is handled by user interface) (HEAD, master) * Dpkg backend: reworked the internal data structure used between DpkgSyntax and the other modules. The new data structure feature the file line number to provide error messages with the line number where the error was found. This patch also tracks what was changed during parsing (see "altered" keyword) to call change_notify with new option "really => 1" (closes debian #670441) * Framework changes: + all: added tracking of changes performed by user. The change list can retrieved from Instance object with list_changes method (this list can be cleared with clear_changes). + Depends on Text::Diff 2.013 2012-04-06 * Application changes: * Debian Dpkg model: Moved libtiff4 transition warning from source Build-Depends to binary Depends * Framework changes: Model doc generation: small formatting fix to avoid Pod::Html errors with Debian/Dpkg/Source.pod (should fix ActiveState breakage) * Test changes: * multitrap tests: really ignore warnings coming from Text::Balanced (which pop up in Perl smoke tests with perl 5.15.9) 2.012 2012-04-05 * Application changes: * Debian Dep-3 patch parser: quilt formats patch in a very concise way. There's no Index: line and no '====='. OTOH, imported patch may contain this lines until the patch is refreshed. This commit makes sure that both types of patch are parsed correctly. * Debian model: changed meta element into my-config. This should make clear that this element stores user's config regarding dpkg files. * Tester: Produced file order is not important. Make sure both list are sorted before being compared (Closes Debian #666705) * Test changes: * multistrap test: ignore load warnings (which pop up in Perl smoke tests with perl 5.15.9) * Framework changes: * Instance: added on_change_cb to take action when something is modified in the config tree 2.011 2012-03-19 * Application changes: + Debian copyright: added deprecated License-Alias paramater. When set to 'Perl', this parameter is migrated into License: Artistic or GPL-1+ + Debian DpkgSyntax: better error message. This was really annoying for DEP-3 patch parser. + cme: added forgotten -stack-trace option * Tester changes: - removed check_* parameter. + Added wr_check parameter + added possibility to pass options to grab and fetch with check and wr_check. 2.010 2012-03-13 * Application changes: * Debian control: * fix warning of section and priority fields + added check and fix for libpng and libtiff4 transistions * Debian Copyright: added warnings if Files uses either [ ] or | (thanks gregoa for the suggestion) * cme: check must check all values * Framework changes: * IdElementReference: use fetch in user mode to get choice list (means values in layered mode) * Value: fetch with allow_undef mode must behave like user mode, not backend mode (fix warp problem in layeredmode) * ValueComputer: added usage of compute as an upstream default value. Some cleanup was done around that 2.008 2012-03-01 * Application changes: * Debian control: + comments are now parsed correctly * Debian copyright model: + added support for deprecated X-Comment. X-Comment fields are converted to Comment fields (note that regular comments are forbidden) * Framework changes: * Requires perl 5.10.1 instead of 5.10.0 * provide file name and line number in syntax error message 2.007 2012-02-26 * cme: fix 'migrate' command. 2.006 2012-02-25 * Application changes: * Debian control model: * bumped default Debian source standards version to 3.9.3 - no longer try to enforce first lowercase in Synopsis. Too many false positives (fix debian #661184) - Removed check for virtual package (source packages are seen as virtual packages). Unfortunately, virtual packages are now reported as unknown packages. Suggestions on how to fix this are welcome. * Debian copyright model: * changed copyright type from line based list to string leaf * Framework changes: + cme: added forgotten 'migrate' command (i.e. cme migrate stuff) 2.005 2012-02-23 * Application changes: * Debian copyright model: updated url for dep-5 format with new Debian approved one. URL is no longer updated silently, user will have to request it with 'cme fix' command 2.004 2012-02-09 * Build.PL runs gen_class_pod.pl which loads Config::Model from lib, hence most of the runtime dependencies are now moved in configure_requires. This should improve Perl smoke tests. 2.003 2012-02-08 * Added configure_requires on File::Slurp (Fix RT#73611) * Updated meta-data to point toward github instead of sourceforge 2.002 2012-02-08 Most of the fixes aim to solve issues with Perl smoke tests * Application changes: * fix bash completion for cme options * Framework changes: * Added dependency on namespace::clean and Mouse * AnyId: remove deprecation warning. check is useful as an alias to check_content * Lister: no need to require perl 5.10 * Tester: don't use next to exit from sub * Tests: * avoid undef $ENV{HOME} problems on Windows 2.001 2012-02-06 Big change this time, hence the version bump tp 2.001. The main change for users is the deprecation of the config-edit program in favor of cme. Instead of using options, this cme uses command keywords like git, so users will have more possibilities while typing less. Internally, some performance improvements were implemented. Given the work required, core Config::Model classes were converted to Moose. In more details: * Application changes: + New cme program to edit/validate configuration. * model Debian::Dpkg: * fixed computed default value for VcsBrowser + added rules element for debian/rules file * DEP-5 model: updated doc and removed obsolete URL. Thanks to skaet for raising this point * Debian/Dpkg/Control/Binary model: + Added deprecated XC-Package-Type. + Added migration from XC-Package-Type to Package-Type * Framework changes: * All: + Improved performance by running validation only when data is modified. (implemented with notify_changes method) * breaks memory cycles in backend manager * Converted to Moose all classes inheriting Config::Model::AnyThing 1.265 2011-12-06 * Application changes: * model Debian::Dpkg: + added Multi-Arch parameter * don't fail when debian/copyright is missing or empty * Framework changes: * Config::Model::Value: layered value is also part of a standard value * Config::Model::CheckList: in custom mode, checklist must return the whole list when queried by user, not just the changed items. (Fix Config::Model::OpenSsh RT#72916) 1.264 2011-11-29 * Application changes: * model Debian::Dpkg: - removed another email check (was hiding in a hg branch) 1.263 2011-11-29 * Application changes: * model Multistrap: * Use convert =>lc on most parameters to match multistrap's behavior + added deprecated forceunpack parameter (migrated to unpack). + force sections and key names to be lowercase + added components parameter to Multistrap::Section model * model Debian::Dpkg: - removed email checks * bash_completion: use new Lister class to gain a lot of speed * Framework changes: + Config::Model::HashId: added convert parameter * Config::Model::Value: recompute choice before checking if a reference matches available choices. + Config::Model::Lister: new bunch of functions to list models and applications. Used only by bash_completion. * Inifile backend changes: * delay validation after read because read order depends on the INI file and not on the model. + added force_lc_(key|name|value) parameter to take care of case insensitive INI files 1.262 2011-11-18 * Config/Model/Tester: avoid test failure by sorting file list before comparing them 1.261 2011-11-17 * Test changes (Config/Model/Tester): * reworked cfg file list check * Avoid test conf pollution from one test to the other + added possibility to specify arbitrary file name (for multistrap) * Application changes: + new multistrap model. Supports multistrap's layered configuration * lcdproc: * lcdconf2model.pl: added better check of info in square brackets * lcdproc/LCDd.conf: resync with upstream lcdproc LCDd.conf * Inifile backend changes: + added write_boolean_as, split_list_value, section_map and join_list_value parameters to cope with special conventions regaring INI files * No longer write empty list parameter (i.e. just "foo=" lines) * ensure that empty sections are not written * Framework changes: * Config::Model::Value: + added write_as parameter for booleans + added clear_preset method + C::M::CheckList, C::M::Instance, C::M::Value: added layered value + C::M::Value::LayeredInclude: new class to include sub-layer of configuration data + config-edit: added -config_file option + added Test::File::Contents build dependency 1.260 2011-10-28 * Application changes * Backend Debian::Dpkg: skip empty lines in patch series files * Framework changes: + Config::Model::Tester: new class extracted from t/model_tests.t to test config files and models. * Config/Model/Loader.pm: Make sure that load("!") goes to root even if load was called from a child node. Fix RT#69480 1.259 2011-10-16 * Application changes * model Debian::Dpkg: Bumped compat default value to 8 * fixed test to work even if lcdproc is not installed 1.258 2011-10-14 * Application changes * model Debian::Dpkg::Patch: Synopsis is no longer mandatory. Issue a warning for empty Synopsis and propose a value based on patch name + model Debian::Dpkg::Meta: added email element + model Debian::Dpkg::Copyright::LicenseSpec: compute license text from Software::License (requires version patched for Debian) * Backend::Debian::Dpkg::Copyright: Rewrote parser to classify correctly Files and Licenses paragraph even if extra fields are prepended. * model Debian::Dpkg::Control::Source: Vcs-browser must also accep https URLs * lcdproc: fixed some specs in square brackets in LCDd.conf template. Reworked model generator to better specs in square brackets and handle model snippets in curly brackets * Framework changes: * ValueComputer: &index and &element can only work with parent or ancestors in tree. Fixed grammar inside of {} statements. It is now able to return '' when no replacement is found * Value: fix warn_if warn_unless check in custom mode. Cleaned up mess about mandatory value checks. Custom values are no longer checked this way 1.257 2011-09-16 * Framework changes: * config-edit: avoid deprecation warning * C::M::AnyId: enable automtic fix of duplicated values * C::M::Node: Create BackendMgr when read_config or write_config is defined (Fixes Debian FTBS in Config::Model::TkUI See #642157) * Application changes + models Debian::Dpkg::Control::Binary and Source: added duplicates warning in dependencies + model Debian::Dpkg::Control::Source: compute Vcs-Browser and Vcs-Git default value for pkg-perl team * model Debian::Dpkg::Patch: No need for a first capital letter restriction. Look for debian patches in the correct places 1.256 2011-09-16 * Application changes * Dpkg control model: warn (and offer to fix) duplicated dependencies + Dpkg model: new compat docs and dirs parameters * Framework changes: * TreeSearcher.pm: properly fix conflict between method name and Moose::Util::TypeConstraints 1.255 2011-09-15 * Framework changes: * Instance.pm, Node.pm: take into account force_load with delayed loading of config files * BackendMgr.pm: New Moose class (renamed from AutoLoader) 1.254 2011-09-04 * fix tests that blow up with Debian build tools 1.253 2011-09-02 * Framework changes: * AnyId: reworked warning storage and display * Value: check can be called without arg to check current value 1.252 2011-09-01 * Framework changes: * AutoRead.pm: correctly handle ~ as home dir (thanks fabreg) * Backend/ShellVar.pm: do not write global comments if there's no data to write * AutoRead.pm: do not leave empty files 1.251 2011-08-30 * Application changes * Backend Debian/Dpkg/Copyright.pm: Fixed parser to avoid confusing License and License-Alias + model Debian/Dpkg/Control/Source.pl: warn in case of duplicated dependencies * Debian/Dependency.pm: Fixed handling of dependency alternates * Backend Debian/Dpkg/Patch.pm: patch write is now working * Framework changes: * Value.pm: rewrote apply_fix to use check to apply fixes. No longer stores fixes as sub ref. * AnyId.pm: rewrote apply_fix to use check to apply fixes. Split check in a global check and dedicated index (check_idx) check * AnyId.pm: Added fix_duplicates feature * Instance.pm: apply_fixes: now relay the call to hash and lists objects * OjTreeScanner.pm: added hooks for node_content hash_element and list_element 1.250 2011-07-22 * Test changes * Debian dpkg tests: reworked cache file syntax (text instead of Perl). Perl file did change randomly depending on order of hash keys. That caused trouble when building Debian packages because running tests did change a source file. * Application changes * Debian Dpkg License model and backend: Reworked Licence models to allow comments and arbitrary parameters in stand-alone licences section (Closes Debian #633847) * Backend Debian::DpkgSyntax: Better handle newlines * Framework changes: * lib/Config/Model/Loader.pm: Raise an exception if a hash of node gets a load string like hash:foo=bar (this one is reserved for hash of leaves) 1.249 2011-07-12 * Framework changes: * Config/Model/Value.pm: * apply_fixes applies all available fixes of a value *then* save the value. * Emit one warning per problem instead of one warning per problematic values (with embedded newlines) * Application changes: * Config/Model/Debian/Dependency.pm: reworked to take buildd limitation into account (check if Perl version is available in sid to decide the order of the alternates dependencies) 1.248 2011-07-05 * Framework changes: * Reworked test framework * New test require new build dependency: File::Copy::Recursive * C::M::Value: allow an enum to have an empty ('') value. * Yaml backend: Do not try to call load_data when YAML file is almost empty (file present but no data in there) * config-edit: force save when command are passed in command line arguements * Application changes: * Debian::Dependency: Do not issue warning when a package is pure virtual (found from local apt cache) * Debian::Dpkg::Control backend: read control information according to element order in config class. This avoids problems when Maintainer field is declared after the Dependencies 1.247 2011-06-27 * Application changes: * examples/lcdproc/LCDd.conf: fix typos * Framework changes: * lib/Config/Model/Backend/IniFile.pm: Fix failure to load in debug trace: do not call location when $obj is undef 1.246 2011-06-17 * Application changes: * LCDd.pl model: re-generated with new C::M::Itself to avoid spurious pod formatting. Fix issue with embedded quotes in Hello and GoodBye parameters. 1.245 2011-06-17 * Application changes: * models Debian::Dpkg::Copyright::License: Allow any license exception keyword (fix Debian bug #627874) + New model for lcdproc: The model for lcdproc (LCDd) is generated from the template LCDd.conf file provided by lcdproc project. This model can be generated by running Dist::Zilla (when working from Mercurial) or by running Build.PL (when working from Config::Model Perl distribution). Note to packagers: LCDd conf files are (c) 1999-2011 William Ferrell and others, GPL-2. Consequently, all LCDd models files (generated from LCDd.conf) are (c) 1999-2011, D Dumont, William Ferrell and others, GPL-2. * Framework changes: * lib/Config/Model/Backend/IniFile.pm: - Do not write twice leaf comments - handle warped_node like nodes * lib/Config/Model/Loader.pm: Do not remove first and last escaped quotes * Build.PL: Check (and may be generate) pod doc at build time (on top of release time) * lib/Config/Model.pm: Fix doc generator to test correctly for time stamp before re-writing docs * lib/Config/Model/Backend/IniFile.pm: When check is 'no', discard data that belongs to unavailable elements 1.244 2011-05-16 * Application changes: * Fstab model: Prevent wrong value in fs_passno and fs_freq with bound mount point * Dpkg: Added doc for control Architecture. Fix pod doc in DpkgSyntax backend * Debian/Dpkg/Meta.pl: applied Debian patch fix_perl_group_filter (set group_filter of debian perl team to 'etch' instead of 'lenny') * Framework changes: * config-edit: added -search and -narrow-search options. This options enable search in tree element, values and tree documentation. * config-edit: cleaned up option names (always accept '-' in place of '_') * Config/Model/AnyThing.pm: fix location string and fix grab function 1.243 2011-05-02 * Application changes: * dpkg control: bumped standard version to 3.9.2 * dpkg: fix spelling . Closes RT# 67783 and 67784. Thanks carnil * dpkg control license: tweaked grammar to accept commas in license fields. Closes Debian #624305. Thanks Niko Tyni. * Dpkg/Control/Source.pl : added XS-Python-Version ans X-Python-Version (first steo to solve Debian #624321) * Debian Dpkg Meta model: package filter is computed from group-filter OR private policy * Framework changes: * reworked warp registration mechanism (Changed inherited WarpedThing into delegation to Warper) * t/debian*.t: Put back Apt::Pkg test to avoid smoke test failure * ValueComputer: Fixed bug to allow temporary variables and $_ in eval'ed formulas 1.242 2011-04-07 * Application changes: * dpkg control: added Build-Conflicts field * dpkg: Added model for debian/source/options and debian/clean files * Framework changes: * Value: don't perform value check when fetching standard or default value * Backend/Plainfile: now support list element in the form of multi line file. Each line of the file is a value of the list. * t/fuse_ui.t: skip test if lsmod cannot be used (e.g. Mandriva) * t/debian*.t: skip test when /etc/debian_version is not found 1.241 2011-04-07 * Framework changes: * Build depend on Test::Differences * Load and grab: fix to accept '-' in element names * Model.pm: Added value help and summary in generated documentation * DumpAsData: skip hash keys containing undef values 1.240 2011-04-05 * Framework changes: * Most *.pm: replaced 'no Moose' by 'no Any::Moose' 1.238 2011-04-05 * Framework changes: * Build.PL: removed dead code that cause downstream pacaking problems. * Model.pm: fix cosmetic issue with doc generation. 1.237 2011-04-04 * Framework changes: * added MouseX::NativeTraits dependency (fix RT #67196) * config-edit: fixed typo (fix RT #66403) * Value, Node, AnyId: use dclone to backup constructor parameters * Model: Correctly write author and copyright in doc (i.e not as ARRAY0x0...) * Yaml backend: fill full_dump option (did not work when set to 0) * Application changes: * dpkg control dependency: - Dependency filtering mechanism uses source package name to find filter value in Meta. This makes more sense than using binary package name 1.236 2011-04-01 * Application changes: * dpkg control dependency: - Dependency filtering mechanism now use dpkg meta package_dependency_filter value (i.e. a user parameter). Debian_perl package will be filtered on lenny by default Filter mechanism can be overriden in a package by package basis See Debian::Dpkg::Meta config class for details. - Warn if a package is unknown. - Accepts version specified with dpkg variables. * dpkg control and copyright: warn if dh-make-perl boilerplate is found * dpkg control: added Package-Type parameter (Peter Pentchev) * Dpkg meta: new class to enable user to customize dpkg editor. (email-updates and dependency-filter). Content of meta is saved in ~/.dpkg-meta.yml * Dpkg control: change e-mail address based on content of meta email-updates * Framework changes: * Value: added replace_follow parameter to specify automatic replacement based on a hash somewhere in the configuration tree (used by dpkg e-mail update) * Extracted initialisation of reader and writer from new() and moved in init() method to avoid deep recursion on startup. * Use Any::Moose instead of plain Moose * Removed dependency on MooseX::Singleton * Model: added author, copyright, license fields. This data is not used by Config::Model, but can be used in the user interface or to generate config class doc * AnyThing: Fix parsing of multi line annotations. Now use Pod::POM to load annocation from Pod document * dist.ini: Depends on Pod::POM * Model.pm: added generate_doc method * config-edit: new -gen-pod option to generate pod document from config class * HashId: fix default_with_init to be able to auto-create leaf values specified in the model 1.235 2011-03-01 * Application changes: * dpkg control source model: Encourage Standard-Version 3.9.1 * dpkg control dependency: only versions older than old-stable (i.e. not found on madison) will trigger a warning * dpkg copyright: Handle license in header (Closes Debian #614776) * Dpkg copyright backend: skip empty copyright lines * Framework changes: * WarpedThing: Can warp based on the location in a tree. For instance to make an element mandatory in one place and not in another. Used by Debian copyright model * Value: mandatory values also require non-empty strings * config-edit: Force to load all sub-models (i.e. control, copyright) of a top-model (err.. dpkg) when run with option -ui none 1.234 2011-02-21 * factor out comment extraction: code that retrieve comments and tie it to actual config data is generic. Now this is handled by C::M::B::Any::associates_comments_with_data * factored out comment writing in C::M::B::Any::write_global_comments and C::M::B::Any::write_data_and_comments * Fix bad handling of leaf type Ini backend (Thanks Krzysztof for the notice) 1.233 2011-02-11 * Application changes: * dpkg control source model: Added DM-Upload-Allowed and all Vcs-* tags defined in Debian reference guide (Thanks Peter Pentchev for the patch) (Fix RT 65575) * Framework changes: * Backend Ini file: Fixed comment handling * All modules: Improved synopsis. You can now save them in a file and have a working program * Remove crappy handling of comments in load_data methods. * DumpAsData: Write annotations as pod in method dump_annotations_as_pod * Anything: load_pod_annotation load annotations from a pod document * Instance write back: now correctly call all write_back when several nodes in model needs to be called back 1.232 2011-01-30 * Added missing Text::Autoformat dependency 1.231 2011-01-30 * Application changes: * Debian::Dependency: reworked to reduce calls to madison. Report available versions when unnessary version issue is found.). Source is optional. * dpkg control model: added forgotten Enhances and Pre-Depends. Added warnings for too long lines in Description (plus fixes based on Text::Autoformat). Added Synopsis element to better tune warnings and fixes * Framework changes: * FuseUI: Fix undef warning. Ensure that files finish with "\n". Fix bug where value 0 was shown as an empty file. * Added PlainFile backend (each config parameter is stored in its own file. useful for some dpkg data) 1.230 2011-01-21 * Application changes: * Debian::Dependency: don't check debhelper * Debian::Copyright: removed license keyword warnings. (fix Debian #610242), lots of other bug fixes (including debian bug #609889 #610231) * Framework changes: * AnyId: added migrate_keys_from to migrate list or hash content during updgrades. * ObjTreeScanner: Added node_dispatch_cb parameter to setup callback dedicated to specific configuration classes. * ValueComputer: added 'undef_is' to allow undef value in formulas. Useful for complex migration scenario where migration can come from several alternative parmeters. * FuseUI: Fix bug that disabled write in a boolean value 1.229 2011-01-10 * config-edit: added -apply-fixes option * Value: can specify wider replace instruction by using regexp as key of the 'replace' parameter * Debian::Dpkg::Copyright: updtead to new CANDIDATE DEP-5 specification. Copyright files written for older specifications are migrated to the new specification. This should save a lot of typing from my fellow Debian packagers. Feedbacks are welcome. 1.228 2011-01-09 * Specifically require DB_File as this module is not available by default on Ubuntu * Skip Debian dependency tests when AptPkg::Config is not available (non Debian systems) 1.227 2011-01-07 * Model.pm: deprecated name_match parameter in accept specification. The regexp should now be specified as a key of a hash. * Value.pm: warn_if_match and warn_unless_match can speficy instructions to "fix" the value. * WizardHelper: can be set to stop on items with warnings. Added bail_out method to bail out cleanly from wizard helper. * model Debian::Dpkg::Control::Binary: Depends element specifies Perl cargo class Config::Model::Debian::Dependency (see below) * Likewise for Debian::Dpkg::Control::Source Build-Depends* * Debian::Dependency: new class derived from Value to provide checks specific to Debian dependencies (syntax, whether a "(>= vers)" is necessary or not, ... ) * New dependency: LWP::Simple 1.226 2010-12-08 * config-edit: mount fuse file system in the background. (like sshfs) * FuseUI: Improved doc * C::M::Backend::Fstab: improved doc 1.225 2010-12-06 * Build.PL: build depends on Test::Command 0.08 to avoid smoke test problems 1.224 2010-12-06 * Node AnyId Value: get() now accepts check parameter, autoadd parameter * Node AnyId: added children method * Added Fuse interface: configuration tree is mapped to a virtual directory. Use config-edit -ui fuse -fuse_dir some/where to use. Stop with 'fusermount -u some/where' * Recommends Fuse (to be able to use fuse user interface) 1.223 2010-11-28 * Debian/Dpkg/Copyright: removed restrictions on copyright format * dist.ini: added build dependency on Probe::Perl (to run tests that invoke config-edit) * Model.pm: can now load model snippet from Foo.d directory. I.e. *.pl files found in Foo.d are used to augment Foo model. This will be useful to agregate models coming from several teams. For instance any team can extends the Fstab model provided in this distribution. 1.222 2010-11-22 * bash-completion: fixed missing application option * Fstab model: specify '/etc' dir inst 1.221 2010-11-21 * Annotation: can now save annotation for node and list objects * Added new Fstab model and backend. Supports ext2 to ext4 and other file systems. Please contact the author if options are missing. * Fix pod spelling errors (RT #62947). Thanks to carnil for the report and patches. * added config-edit test (build requires Test::Command) * config-edit: added -application option, added -list model|applications option * Model.pm: updated doc * bash_completion.config-edit: is now *not* executable 1.220 2010-11-10 * Fix Build.PL to install files found in lib/Config/Model/*.d * Added Cookbook::CreateModelFromDoc from SF wiki 1.219 2010-11-09 * config-edit: fixed syntax error * replaced command lines generated from template by bash-autocompletion. * Removed dependency on Text::Template * Added Config::Model::Manual::ModelCreationIntroduction doc from SF wiki 1.218 2010-11-05 * Moved doc from README into model.pm * Copyright: added deprecated parameters (Upstream-Name Upstream-Maintainer Upstream-Source). Added migrate_from instruction to migrate user data from old parameters to new parameters. * Copyright: Removed fuzziness around trailing '+' in licence names * AnyThing.pm: grab() : accept '+' without surrounding quotes in argument * WarpedNode: delegates copy_from and dump_tree to Node (fixes hash copy with warped nodes) * config-edit: added -open_item option * Build.PL: configure_depends on Text::Template to avoid CPANPLUS installation failure 1.217 2010-10-26 * Fix issue where value reference did not follow refered to parameters after creation. * Fstab example: split the model for the Debian mini-debconf workshop 1.216 2010-10-26 * Control.pl: fixed control fields order to be less confusing (thanks to ansgar for the advice) * Backend IniFile: Bug fix to write top level parameters before the first INI class * Node.pm: Bug fix when calling fetch_element with accepted parameters * Model.pm: updated doc to point to overview and introduction on SourceForge wiki * example/fstab/Fstab.pl: Fix model so it can be loaded by config-model-edit 1.215 2010-10-19 * Instance.pm and Loader.pm: added some stub to preserve backwards compatibility 1.213 2010-10-19 * AutoRead.pm: do not clobber configuration file when trying to write erroneous data * Value.pm: fix value check based on Parse::RecDescent * Dpkg::Copyright: fix bugs masked by above problem * Dpkg::Copyright: Fix read/write issues with License that can be stored either in Files section or their own sections 1.212 2010-10-15 * Value and AnyId: store wrong values when store check is disabled (i.e. config-edit is run with -force option). * Debian::Dpkg::Copyright: cosmetic improvements on written file * Instance.pm: Removed all overengineered push_no_value_check, pop_no_value_check. This stuff had too many drawbacks of global variables. An optional check parameter was added to a lot of calls on Config::Model. The API was also sanitized with some positional parameters replaced by named parameters. Most of these changes should be internal. The main impact is that read/write backends must now explicitely pass this check parameter lest the force_load will not work. * ValueComputer: Remove req on Parse::RecDescent version. (Debian bug #597794) * Value.pm: added silent parameter to fetch method to avoid displaying warnings on STDOUT * Enable read and write of utf8 characters 1.211 2010-10-01 * Value.pm: added warn_if_match and warn_unless_match parameters. Value will issue a warning if the stored value match (or does not) match a Perl regular expression specified in the model. * AnyId.pm: Likewise, added warn_if_key_match and warn_unless_key_match. * Value.pm: added warn parameter. Unconditionaly issue a warning with a string specified in the model. Mostly usefull for deprecated or accept'ed parameters * Loader.pm: load string can now undef a leaf with '~' action. E.g load("foo~") will set foo parameter to undef. * Copyright model: warn if unknown license is used. 1.210 2010-09-30 * renamed config-edit-dep5 in config-edit-dpkg-copyright * renamed Debian::Dep5 model to Debian::Dpkg::Copyright * renamed Config::Model::Backend::Debian::Dep5 backend to Config::Model::Backend::Debian::Dpkg::Copyright * Factored out code to read/write control files in Config::Model::Backend::Debian::DpkgSyntax * Created model and backend for Debian control files * added config-edit-dpkg-control command line 1.209 2010-09-20 * Fixed Debian::Dep5 parser: fixed read issue and added write capability 1.208 2010-09-16 * Fixed missing dependencies in Build.PL (Building from hg requires Dist::Zilla and Dist-Zilla-Plugins-CJM >= 3.01) 1.207 2010-09-14 * Added Debian's Dep-5 model (with config-edit-dep5 CLI) * Value.pm: Added validation of value based on a Parse::RecDescent grammar * AnyId.pm: Authorized keys can also be based of a Parse::RecDescent grammar * Node.pm (find_element): returns the element name (if known). Can also find the element in a case insensitive manner 1.206 2010-07-23 First version to feature code written during Google Summer of Code 2010. For this GSoC, Krzysztof Tyszecki has provided: * a new backend for INI file that can: * read and write comments to and from annotations. This way users comments are preserved * read and write parameters that are repeated in the INI file. This repeated parameters will be loaded in list elements * the capacity to load annotation from perl data structure * a new model feature to accept unknown element. This will enable loading and writing configuration files even if parameters are unknown. This feature is required to create models targeted for configuration upgrades: only upgrade and migration specifications need to be specified in a model. Parameters that don't change from one version to another need not to be specified in the model. Other changes: * lib/Config/Model/Loader.pm (_walk_node): bug fix to load node element annotation * lib/Config/Model/Dumper.pm (): bug fix to dump hash and list element annotations * Fixed Fstab example 1.205 2010-06-04 * t/node.t: patch by Niko Tyni to avoid Carp::Heavy failure. Fix Debian FTBS bug #582915 and countless CPAN smoke tests failures 1.204 2010-06-03 * MANIFEST.SKIP: Prompt re-release because 1.203 tarball contains debian packages used for tests (oops) 1.203 2010-06-03 * lib/Config/Model/Loader.pm (_load_hash): Bug fix: can load annotation tied to hash values (node or leaf). 1.202 2010-04-22 SUMMARY: * New core feature: user can store annotation (e.g. structured comments) with each configuration object of the configuration tree, be it node, leaf, hash or list. Read backend can parse confguration file comments and store them in annotations. For instance ShellVar read backend will parse comments and store them in the configuration tree. ShellVar write backend will put them back in the configuration file. * PopCon editor preserve comments in configuration file. * Code: Uses Moose for C::M::Annotation and C::M::Backend::Any. Moose looks good. I may use Moose for all other Config::Model classes later. * lib/Config/Model/Backend/ShellVar.pm (read): Tries its best to read user comments and store them in annotations. (write): Write annotation as comments. Write model documentation as comments starting with '##' * lib/Config/Model/AnyThing.pm (grab_annotation): new method * lib/Config/Model/Loader.pm (load): Can load string with annotations * lib/Config/Model/Dumper.pm (dump_tree): Dumps annotations in data string * lib/Config/Model/AnyThing.pm (annotation): new accessor method for annotations. * lib/Config/Model/Annotation.pm : New file to load and save configuration annotations (just like comments with a structure) * Build.PL: added dependency on Moose * lib/Config/Model/models/PopCon.pl: Fixed PopCon config directory. Cosmetic improvements for descriptions. * lib/Config/Model/*.pm: Put back VERSION number and bumped them all to 1.201 to make CPAN indexer happy 1.001 2010-03-28 * Build.PL (process_tmpl_files): Build depends on Text::Template. Generates config-edit-popcon * config-edit.tmpl: New file to create dedicated config-edit-foo commands * lib/Config/Model.pm: Version bumped to 1.001 * lib/Config/Model/Backend/ShellVar.pm : New backend to read and write configuration files used by shells (sourced by scripts) * lib/Config/Model/WizardHelper.pm (node_content_cb): no longer forget to scan element that are warped in while scanning the node. * lib/Config/Model/Node.pm (previous_element): new method to iterate through availalble node elements * lib/Config/Model/Value.pm (setup_match_regexp): added new 'match' parameter to validate a value against a Perl regular expression. * lib/Config/Model/Node.pm (load_data): can load data in hidden element when store check is ignored. 0.644 2010-03-11 * lib/Config/Model/Loader.pm (load): Load string now support: - '.=' operator to append to config values. - '=~' to loop configurations instruction over list or hash elements * all: Applied spelling corrections done by Debian Perl team (thanks gregoa) 0.643 2010-02-23 * lib/Config/Model/DumpAsData.pm (dump_as_data): Can dump ordered hash in hash ref with __order key to specify order of hash elements * lib/Config/Model/HashId.pm (load_data): Accept hash ref with __order to load ordered data * lib/Config/Model/AnyId.pm: For better clarity, Hash and List parameter max and min are changed to max_index and min_index. Backward compatibility is kept, but warning will be displayed on the terminal when the old parameters are used. * lib/Config/Model/Backend/Yaml.pm: New backend to read and write YAML configuration files. * lib/Config/Model/CheckList.pm (set): buf fix: split input value to get the list of checked items. Migrated to Log4perl * lib/Config/Model/CheckList.pm: Fixed default and upstream default handling 0.642 2010-01-21 * lib/Config/Model/WarpedNode.pm: added get_help to methods forwarded to Node object to avoid breaking the graphical model editor 0.641 2010-01-19 * lib/Config/Model/Node.pm: Ported to Log4Perl (Tree::Node class) * lib/Config/Model/AutoRead.pm: Doc updates on plugin mechanism for read/write classes * lib/Config/Model/Value.pm: model example updates * lib/Config/Model/Dumper.pm (dump_tree): Correctly quote values in list elements * lib/Config/Model/HashId.pm: Ported to Log4Perl (Tree::Element::Hash class) * lib/Config/Model/Instance.pm (write_back): Croak if no write_back callbacks were registered 0.640 2009-09-09 * lib/Config/Model/WizardHelper.pm (new): Correctly scan list element. 0.639 2009-07-30 * lib/Config/Model/WizardHelper.pm (leaf_element_cb): bug fix: scan correctly leaf elements of a hash. * lib/Config/Model/WizardHelper.pm: use Log4perl * config-edit: Tk cosmetic improvement. Thanks to Jerome Quelin for the suggestion * lib/Config/Model/WarpedThing.pm (_do_warp): Use Log4Perl. Improved error message * lib/Config/Model/Searcher.pm (): replace prints with Log4perl. Fixed data structure bug 0.638 2009-06-29 * lib/Config/Model/WarpedNode.pm (is_auto_write_for_type): Added new method that need to be forwarded to Node to avoid write cds_file bug. 0.637 2009-06-23 * lib/Config/Model/Value.pm: As suggested by Jonas Smedegaard, replaced 'built_in' parameter with 'upstream_default'. This change will trigger warnings but no errors with existing model. To get rid of the warnings, the easiest solution is to update the model by running "config-model-edit -model Foo -save" (config-model-edit is provided by Config::Model::Itself) * lib/Config/Model/CheckList.pm: replaced 'built_in_list' parameter with 'upstream_default_list'. This change may also trigger warnings. These warnings will also be fixed by running the config-model-edit command described above. * lib/Config/Model/Value.pm: use Log::Log4perl with categories Tree::Element::Value and Tree::Element::Warper 0.636 2009-05-30 * lib/Config/Model/AutoRead.pm: Added skip_open to avoid opening config target file when the open must be done by the backend (e.g. for Augeas backend) * lib/Config/Model.pm (instance): name parameter is no longer mandatory. Uses 'default' as default instance name. * lib/Config/Model/AutoRead.pm: When calling backend, 'file' parameter contains configuration file name without path and 'file_path' parameter contains complete path and file name 0.635 2009-04-17 * config-edit: added -dumptype option. -dump can now be used to specify a file name * lib/Config/Model/Instance.pm (new): Added skip_read parameter * lib/Config/Model/Node.pm (new): Added skip_read parameter * config-edit: Fix broken Log4Perl default config. Added -load option * lib/Config/Model/AutoRead.pm (): Reworked doc. Aligned read and write specs (now have same parameters). Read and write callback are passed an opened file handle if possible. Now use Log::Log4perl. * lib/Config/Model.pm (include_one_class): Can no longer clobber element with 'include' class feature. * lib/Config/Model.pm (check_class_parameters): Accept summary parameter. Summary is optional and will be used either to generate user interface or may be used to provide comments in saved configuration files. * lib/Config/Model/Node.pm (get_help): added options to get either summary or description of an element * config-edit: added -dump and -load options 0.634 2009-02-24 * config-edit: removed kludgy read_root_dir and write_root_dir options. For test, only one root_dir can be specified (like Augeas) * lib/Config/Model/ListId.pm: auto_create parameter is replaced by auto_create_ids (still trap wrong parameter to avoid memory problems) * lib/Config/Model/HashId.pm: auto_create parameter is replaced by auto_create_keys * lib/Config/Model/ListId.pm (auto_create_elements): Trap wrong auto_create argument (avoid massive memory consumption) 0.633 2008-12-23 * lib/Config/Model/AutoRead.pm : Added -allow_empty parameter so starting a configuration from scratch can be allowed by configuration model designer. No longer die if 'augeas' backend (or any other optional backend) is not found. Just emit a warning. 0.632 2008-12-16 * config-edit: added -backend parameter so (advanced) user can specify which read/write backend to use. The actual backed to use depends on the model loaded with -model option * lib/Config/Model/Instance.pm (write_back): Added backend parameter to specify which backend to use to write. By default, all backend are tried until one succeeds. This parameter can also be specified when calling the constructor 0.631 2008-11-10 * lib/Config/Model/Value.pm (_pre_fetch): removed dependency on Error * lib/Config/Model/WizardHelper.pm : removed dependency on Error * lib/Config/Model/AutoRead.pm (auto_write_init): Move Augeas read/write feature out of Config::Model. This feature is now available in an additional class: Config::Model::Backend::Augeas. This class is distributed in its own Perl distribution. * lib/Config/Model/Dumper.pm (dump_tree): No longer dump list elements that contain only undef values. No longer dump node that do not contain data. 0.630 2008-10-21 * t/augeas_backend.t: Skip sshd_config tests if Augeas library <= 0.3.1 0.629 2008-10-13 * lib/Config/Model/CheckList.pm (set_properties): Added ordered parameter to checklist. Ordered checklist feature is required by Ssh model for Ciphers list (see Config::Model::OpenSsh). * lib/Config/Model/AnyId.pm (get_cargo_info): New method 0.628 2008-09-29 * lib/Config/Model.pm: Allow include of read or write config parameters (required by Xorg model) 0.627 2008-09-23 * ChangeLog: I plainly forgot to update this file for v0.626. This is fixed now. 0.626 2008-09-22 * lib/Config/Model/AutoRead.pm (read_augeas): Lot of bug fix to read and write through Augeas. Now, lens containing 'seq' lenses must be explicitely declared. * lib/Config/Model/Value.pm (migrate_value): No longer fails when a migrated value is also a mandatory value. * lib/Config/Model.pm (create_config_class): No longer creates empty include in model when skip_include is true (breaks Config::Itself tests) 0.625 2008-07-30 * lib/Config/Model/ListId.pm (swap): Swapped or moved values in a list no longer provides wrong location in config tree. (index_value were not updated in objects contained in List after a swap or a move) 0.624 2008-07-24 * lib/Config/Model/Value.pm and others: Modified to allow smooth configuration data upgrades without requiring user input (if used by packaging, this should really help in avoiding rpmsave or dpkg-old files) (See migrate_from parameter) * lib/Config/Model/ValueComputer.pm: added 'use_eval' parameter to allow more complex computation like regexp in string or uniline values * lib/Config/Model/AutoRead.pm: Major changes to interface Config::Model with Augeas (http://augeas.net). Changes are compatible but new warnings are issued: - 'syntax' is replaced by 'backend' to indicate that permanent storage of configuration data is more than a matter of writing a configuration file. - introduced 'config_dir' and 'root' paramater so a backend can specify a configuration dir (e.g. /etc/foo) and a pseudo-root to perform tests (so the config file can land in my_root/etc/foo). * lib/Config/Model/Dumper.pm (new): skip_auto_write now take a storage backend name as a parameter instead of a boolean (See AutoRead for explanations about backends) * lib/Config/Model/Node.pm (set): New method to emulate (part of) augeas API (get): New method to emulate (part of) augeas API * lib/Config/Model/Loader.pm (): Added load command '~' which was forgotten. This command can delete hash or list item. I.e. load("foo~") will delete element 'a' for hash 'foo' (_load_list): command '=' now clear all values before storing the set of values in the list. * lib/Config/Model/AnyId.pm (clear_values): New method to clear values without destroying underlying objects. (set): New method to emulate (part of) augeas API (get): New method to emulate (part of) augeas API * lib/Config/Model/AutoRead.pm: Changed 'syntax' paramter to 'backend' as configuration data may be stored to files or through dedicated libraries like Augeas, gconf ... Backend now can be cds_file, perl_file, ini_file and custom 0.623 2008-05-19 * Build.PL: Moved from Makefile.PL to Build.PL * lib/Config/Model/CheckList.pm: added support for built_in default list * lib/Config/Model/SimpleUI.pm: Some cleanup. Added possibility to add and element name to 'll' command * config-edit: added "dev" and "experience" options. With "dev" option, config-edit will add "lib" to @INC and look for models in "lib" * lib/Config/Model/Node.pm (fetch_element): Bails out if element is hidden (this feature was forgotten) * lib/Config/Model/Value.pm (submit_to_compute): Fix bug where a compute variable in the form 'foo' => '- - &element' did not work (new): allow_compute_override is deprecated in favor of allow_override within the compute parameter (backward compatible change) * lib/Config/Model/AnyThing.pm (dump_as_data): dump_as_data can now be called on all configuration elements. (before, it could only be called on nodes) * lib/Config/Model/AutoRead.pm: Changed the way to specify auto read and write for better clarity. Now they must be specified with read_config => [ { syntax => 'ini'}, { syntax => 'custom', class => 'Mine', function=>'my_read' } ] instead of read_config => [ 'ini', { class => 'Mine',function=>'my_read'}] likewise for write_config * lib/Config/Model.pm: Changed 'permission' to 'experience' and 'intermediate' to 'beginner' for better clarify. Changes are backward compatible. * lib/Config/Model/HashId.pm (move): New method to take into account move within ordered hash * lib/Config/Model/WarpedThing.pm (compute_bool): warp rule no longer fail with eval $foo == 1 when $foo is undef 0.622 2008-04-18 * Value.pm (fetch): added 'allow_undef' mode to allow reading undefined mandatory value (fix morphing warped node containing undefined mandatory values) * Node.pm (copy_from): No longer die when copying undefined mandatory value. * AutoRead.pm (get_cfg_file_name): Do not use ':' in file names. This breaks windows. Now use sub-directories * Dumper.pm (dump_tree): skip undefined values in list element * DumpAsData.pm (dump_as_data): idem * Model.pm (list_class_element): New method to help debugging of configuration models * Model.pm (include_class): allow multiple includes * AnyId.pm: Changed the way the cargo parameter are specified. Now the cargo parameter holds all the information related to the payload of the hash or list. Instead of having : cargo_type => ... , cargo_args => {}, config_class_name => ... you now have: cargo => { type => ..., config_class_name => ..., => ... } Model.pm provides a translation from the old way to the new way so this change is (95%) backward compatible. * CheckList.pm (set): Fix bug that prevented to use level or permission or status parameter with check_list elements * Value.pm (pre_store): Fix bug that prevented to load models with errors even in tolerant mode. 0.621 2008-04-03 * Dumper.pm (dump_tree): Added auto_vivify parameter * DumpAsData.pm (dump_as_data): By default, now provide full dump (with default values). Added auto_vivify parameter * Value.pm (fetch): Check for mandatory values even if fetching only custom values * Value.pm (): Cannot warp value_type anymore (this feature was hard to use and encouraged too complex model). * HashId.pm (swap): Fix swap problem which led to duplicated keys in ordered hash (move_after): New method * ListId.pm (swap): new method (remove): New method, equivalent to splice (@list,$idx,1) 0.6201 2008-03-20 * Makefile.PL: Removed dependency on Term::ReadLine::Gnu. This module is just suggested (as well as Term::ReadLine::Perl) 0.620 2008-03-18 * TermUI.pm: Fixed to work with Term::ReadLine::Gnu or Term::ReadLine::Perl. Can also work in degraded mode without these 2 modules. The command handling part was moved to SimpleUI.pm * config-edit: added Simple UI mode so config-edit can be used with stdin and stdout 0.619 2008-02-29 * Value.pm: removed kludgy enum_integer value type * Instance.pm (write_back): can override directory where config data is written back (necessary for GUI menu like "save in dir ...") * Node.pm (get_help): do not mangle description text (don't remove spurious \s and \n. Leave that to user) 0.618 2008-02-12 * AnyThing.pm (composite_name): new method to return a name like element:index or element. * CheckList.pm (): added refer_to and computed_refer_to accessors 0.617 2008-01-28 * config-edit: added possibility to load Tk GUI (still under development) * Exception.pm (): Fixed misleading error message for UnavailableElement exception * Value.pm (): added "replace" parameter for enum Value. This enables to specify a substitution when storing value. * WarpedNode.pm (check): no longer die when trying to retrieve warped out node, just return undef. This is necessary to be able to load configuration files with important error (e.g. a xorg.conf file with a wrong device driver: all driver option are no longer valid.) * Value.pm (check): Added doc for check. * ObjTreeScanner.pm (permission): new method to get or set the permission of the scanner (after creation). 0.616 2007-12-04 * AutoRead.pm (read_ini): added capability to read configuration data from ini file (See Config::Tiny) (write_ini): can use ini files to store configuration data (read_perl): added capability to read configuration data from a perl data structure (see Config::Model::DumpAsData) from a .pl (write_perl): can use perl file to store configuration data (.pl file) (auto_read_init): configuration model can specify cds (dump string see Config::Model::Dumper), perl or ini with 'read_config' and 'write_config' parameter. 0.615 2007-11-15 * config-edit: added '-force-load' option to load erroneous configuration data. bad data is discarded. * Value.pm : handle 'preset' mode to store values (fetch):accept mode parameter ( [ custom | preset | standard | default | non_built_in ] ) * Loader.pm (_load_list): When loading list, empty value are considered as undef values. I.e 'list_a=a,,"",d' will load ('a',undef,'','d') to lista element * Instance.pm (new): added 'force_load' parameter to load erronueus configuration data. In this case, wrong data will be discarded. (preset_start): new. Use this method, then load configuration data that will be used as "preset data". You can use this feature to load data discovered by an automatic mechanism, like hardware scan. (preset_stop): new. Stop preset mode. Then all data entered will be considered as 'custom' data. These custom data can be compared to 'default' or 'preset' data for audit purpose (preset): new. Query if the instance is in 'preset' mode. * Dumper.pm (dump_tree): changed 'full_dump' parameter (0|1) to 'mode' (full | preset) (dump_tree): if a list contain undef values, they are dumped as a_list=a,b,,d. Empty values are dumped as a_list=a,b,"",d * CheckList.pm (store): work in preset mode (set_checked_list_as_hash): accept a mode parameter ([ custom | preset | standard | default ]) to be able to audit config data (fetch): idem 0.614 2007-10-19 * Value.pm: added 'uniline' value type for string with no embedded newline. (no "\n") * Model.pm (translate_id_names): new method to translate AnyId parameter changes * AnyId.pm: Changed some parameters: follow -> follow_keys, allow -> allow_keys, allow_from -> allow_keys_from * Model.pm (translate_id_default_info): provides backward compatibility for AnyId parameter changes. * AnyId.pm: default parameter is replaced by 'default_keys' and 'default_with_init'. 0.613 2007-09-25 * IdElementReference.pm: Changes the API of IdElementReference so that API is more explicit (Like the API change for ValueComputer). This change is backward compatible (model translation) * ValueComputer.pm: Now compute paramater must use explicit parameters for compute formula, variables and replace. Backward compatibility is kept by translating old compute declaration in Model.pm * Model.pm (include_class): permission, level and description parameters can also be declared within the element declaration. (i.e. at the same level than 'type' ) * IdElementReference.pm (): A reference to a list will now take into account the values of the list instead of the indexes of the list. This makes more sense... * CheckList.pm: Change the name of 'default' parameter to 'default_list' ('default' is still accepted but is deprecated) * WarpedNode.pm: improved synopsis in doc (load_data): new method (forgotten in 0.612) * Model.pm: -doc: added synopsis - inherit is deprecated in favor of include - inherit_after is deprecated in favor of include_after - Raise an exception if an element is declared twice in a model (even through include mechanism: overriding an included element leads to confusion) 0.612 2007-07-26 * HashId.pm : can preserve hash key order (when created with ordered => 1). New method to manipulate hash key order are swap, move_up, move_down. * Exception.pm :new error class Config::Model::Exception::LoadData * AnyThing.pm (grab): added 'grab_non_available' parameter. * AnyId.pm: added "ordered" parameter to create ordered hash elements. I.e. hashes where the order of the keys is kept (like Tie::IxHash) * Value.pm (load_data): new method * Node.pm (load_data): new method (dump_as_data): new method * Model.pm (inherit_class): added inherit_after parameter. In a model, the order of the elements is important. This parameter enable a model to inherit elements from another class and to place them in a specific place among the original elements. (load): returns the names of the class loaded by this method. * ListId.pm (load_data): new method * HashId.pm (load_data): new method * CheckList.pm (load_data): new method 0.611 2007-07-03 * WarpedThing.pm: Modified the way to specify complex warped rules. The former way based on list of lists was confusing. Now you can specify boolean expressions to find the warp rule to apply. * Model.pm: Simplified config class inheritance mechanism: inherit all or nothing. Added translation of legacy warp parameter (based on list of lists) to new warp parameters (based on boolean expressions). So the change done in WarpedThing is backward compatible. 0.610 2007-06-06 * Model.pm (inherit_class): Fix configuration class inheritance mechanism * Value.pm: can also warp help for enum value 0.609 2007-05-09 * config-edit: renamed from config-model * examples/fstab/fstab_test.pl (produce_fstab): added curses interface example (need to install Config::Model::CursesUI to work) * config-model: added possibility to use the curses interface provided by Config::Model::CursesUI (if this one is installed) * ValueComputer.pm: Modified so compute may return an undef value if one of the variable (extracted from the configuration data) of the formula is undefined. In other word, propagate undef instead of croaking. * Searcher.pm: Lots of bug fixes (get_searchable_elements): new method (prepare): new method. Search is now done in 3 moves: create the searcher object, prepare the search, and run the search * Value.pm: removed unique_value parameter which was a bad idea for a check list implementation. Moved reference handling into new IdElementReference class * IdElementReference.pm: New class extracted from Value object so reference can be used also by CheckList * CheckList.pm: re-wrote as a "check_list" type and not a "list" type * Instance.pm (reset_config): new method (searcher): renamed search_element to searcher. searcher retunrs a Config::Model::Searcher object. * AnyThing.pm (searcher): renamed search_element to searcher. searcher retunrs a Config::Model::Searcher object. * AnyId.pm (copy): new method to deep-copy the content of a hash or id element. * Value.pm: moved out reference facility in Config::Model::IdElementReference * Value.pm (fetch_no_check): new method 0.608 2007-02-23 * ObjTreeScanner.pm: Clarified call-back names. 0.607 2007-01-12 * t/term_ui.t: Changed tests to try to load Term::ReadLine and skip tests if Term::ReadLine cannot be loaded. 0.606 2007-01-11 * config-model: Corrected wrong doc for options. * Describe.pm: Small cosmetic changes in output. 0.605 2007-01-08 * config-model: Now uses Log::Log4perl. (Still need to use Log4perl for all *.pm files though). Now write config files back. Added option to read and write config in test directories. * *.pm: Changed e-mail address to reduce spam. * *.pm: Small bug and doc fixes. * Model.pm (load): Model files are expected to be delivered as Perl module and are searched using @INC. (E.g. Xorg.pl model will be searched as Config/Model/models/Xorg.pl in @INC elements) * Exception.pm (full_message): Clarified error message of RestrictedElement exception * examples/fstab/fstab_test.pl: Clarified notifications shown to user. Adapted to changes of 0.604 0.604 2006-12-06 * Node.pm: added check_list in possible element of a node. * Value.pm (set): Changed reference declaration: now value_type must be set to 'reference' when using 'refer_to' parameter. * WarpedThing.pm: can group rules declaration in warp argument to save typing * WizardHelper.pm: adapted for ObjTreeScanner changes * ObjTreeScanner.pm: Modified the callback signature so the user does no longer have to play with closures. - added check_list_cb for CheckList elements - improved doc - added callback example in doc * AutoRead.pm (auto_write_init): bug fix in auto_write functions * AnyId.pm (new): New allow and allow_from parameters to set "allowed" keys of a hash or list. This list of allowed keys can be fixed or dynamic. * AnyThing.pm (root): new method. Returns the root node of the configuration tree. (grab): bug fix so hash identifier can contain white spaces when calling grab (e.g. InputDevice:"Configured Mouse") * CheckList.pm: New class to implement a check list. * Describe.pm: adapted for ObjTreeScanner changes and new CheckList element type * Dumper.pm: idem * Report.pm: idem 0.603 2006-10-19 * Value.pm (set): forbids to specify both 'refer_to' and 'value_type' in value declaration * Loader.pm (load): Accepts now to load configuration data where index can contain white space. (e.g. Monitor:"Hercules Pro") * AnyId.pm: changed 'element_args' to 'cargo_args'. Changed 'element_class' to 'cargo_class'. Added 'follow' parameter so a hash key can mimic the keys of another hash in the configuration tree. * TermUI.pm: removed debug print. This makes auto-completion much easier to understand ;-) * Value.pm (set_default): added built_in default parameter. Built_in default parameter are not written in configuration files but can be used to audit configuration data. * AutoRead.pm (auto_read_init): bug fix: override of read_dir was not taken into account (auto_write_init): idem for write_dir * Instance.pm: added doc for the possibility to specify where to read or write the configuration files. * AnyId.pm (move): also change index value when moving items. 0.602 2006-09-07 * config-model: added -help and -man options to command line * Model.pm (load): model file now must return an array ref and not invoke Model methods. See t/big_model.pm for an example (load): can load model file for model class that contain '::'. In this case the model file is searched in a sub-directory just like a perl class (E.g Model::Foo -> Model/Foo.pm) * HashId.pm (create_default): can initialise children nodes while creating default keys. (Necessary to be able to write a configuration model for Xorg) * AnyId.pm (move): new method 0.601 2006-07-20 * config-model: new program. This programs can be invoked to modify configuration files (provided the corresponding model is available in /etc/config-model.d). (Still shaky. Don't run as root) * Node.pm (get_type): new method (get_cargo_type): new method (get_element_name): added type and cargo_type parameters to filter returned element depending on their type or cargo (contained) type (describe): new method. Uses new Describe.pm file * Value.pm (get_type): new method (get_cargo_type): new method * Model.pm (load): new method. Model can load model declaration from /etc/config-model.d. The model must be valid perl script that ends with an array ref containing configuraiton class declaration like the one accepted by create_config_class * ListId.pm (get_type): new method * HashId.pm (get_type): new method * Exception.pm : Added WrongType exception for new grab parameters * AnyThing.pm (get_type): New method (grab): added strict, autoadd, type parameter. * AnyId.pm (get_cargo_type): new method. (config_class_name): new mehtod * Describe.pm: New file. Provides a human readable description of a configuration node. 0.507 2006-06-15 * TermUI.pm: New file. Provides a shell like interactive user interface. * Node.pm: Now inherit AutoRead class * Instance.pm: Adapted for auto read/write. * AutoRead.pm: New file. Provides node the capabilities to load config data when creating a configuration node. 0.506 2006-05-19 * examples/fstab/FstabModel.pl: added Fstab example with its fstab configuration model. This example includes a small program that use this model to show some ways to extract configuration informations. * Report.pm: new file. Provides report and audit facility for Node.pm * Node.pm (report): new method (audit): new method * Model.pm (create_config_class): added inheritance of configuration models. * HashId.pm (_get_all_indexes): sort returned indexes * Dumper.pm (dump_tree): fix list dump which did not work * AnyId.pm (fetch_all_values): new method 0.505 2006-04-21 * WizardHelper.pm: New file. This class helps to create wizard widget for config models * Makefile.PL: ValueFormula is no longer compiled at build-time but on the fly at run-time. Hopefully this will fix Windows problem and ease integration downstream for a minor performance penalty at start time. 0.504 2006-04-10 * Searcher.pm: Added search element feature. This feature provides a way to search for a configuration element in a configuration tree. The search can be launcher from an instance or any node of a configuration tree. Getting to searched target can be manual or automatic (with call-backs provided by user) * Makefile.PL: Changed grammar pre-compilation to add a "1;" at the end of ValueFormulaParser.pm (Makes Windows happy) 0.503 2006-03-16 * Makefile.PL (MY::postamble): Corrected CPAN dependencies Config-Model-2.149/CONTRIBUTING.md0000644000175000017500000000776014170053137014702 0ustar domidomi# How to contribute # ## Ask questions ## Yes, asking a question is a form of contribution that helps the author to improve documentation. Feel free to ask questions to the [author](mailto:ddumont@cpan.org) ## Log a bug ## Please report issue on the issue tracker that best match your problem. If you don't know please use [cme issue tracker](https://github.com/dod38fr/cme-perl/issues). Here are the dedicated trackers: * problem with cme command: https://github.com/dod38fr/cme-perl/issues * problem with `cme check|fix|edit openssh`: https://github.com/dod38fr/config-model-openssh/issues * problem with `cme check|fix|edit systemd`: https://github.com/dod38fr/config-model-systemd/issues * problem with `cme check|fix|edit systemd-user`: https://github.com/dod38fr/config-model-systemd/issues * problem with `cme check|fix|edit lcdproc`: https://github.com/dod38fr/config-model-lcdproc/issues * problem with `cme check|fix|edit approx`: https://github.com/dod38fr/config-model-approx/issues * problem with `cme check|fix|edit dpkg`: run `reportbug libconfig-model-dpkg-perl` * problem with `cme check|fix|edit popcon`: https://github.com/dod38fr/config-model/issues * problem with `cme check|fix|edit multistrap`: https://github.com/dod38fr/config-model/issues * problem with `cme meta edit`: https://github.com/dod38fr/config-model-itself/issues * problem with cme GUI: https://github.com/dod38fr/config-model-tkui/issues ## Source code structure ## The main parts of this modules are: * `lib/Config/Model/**.pm`: the core framework files * `lib/Config/Model/Backend/**.pm`: classes used to read and write configuration files * `lib/Config/Model/models/**.pl`: the model of the applications delivered with this module. These files can be modified with `cme meta edit` command. Their structure can be viewed with `cme meta gen-dot` and `dot -Tps model.dot > model.ps` * `lib/Config/Model/models/**.pod`: the doc of the above models. Can be re-generated with `cme gen_class_pod` * `t`: test files. Run the tests with `prove -l t` * `t/model_tests.d` test the application delivered with this module using [Config::Model::Tester](http://search.cpan.org/dist/Config-Model-Tester/lib/Config/Model/Tester.pm). Use `prove -l t/model_test.t` command to run only model tests. ## Edit source code from github ## If you have a github account, you can clone a repo and prepare a pull-request. You can: * run `git clone https://github.com/dod38fr/config-model/` * edit files * run `prove -l t` to run non-regression tests There's no need to worry about `dzil`, `Dist::Zilla` or `dist.ini` files. These are useful to prepare a new release, but not to fix bugs. ## Edit source code from Debian source package ## You can also prepare a patch using Debian source package: For instance: * download and unpack `apt-get source libconfig-model-perl` * jump in `cd libconfig-model-perl-2.086` * useful to create a patch later: `git init` * commit all files: `git add -A ; git commit -m"committed all"` * edit files * run `prove -l t` to run non-regression tests * run `git diff` and send the output to the [author](mailto:ddumont@cpan.org) ## Edit source code from Debian source package or CPAN tarball ## Non Debian users can also prepare a patch using CPAN tarball: * Download tar file from http://search.cpan.org * unpack tar file with something like `tar axvf Config-Model-2.086.tar.gz` * jump in `cd Config-Model-2.086` * useful to create a patch later: `git init` * commit all files: `git add -A ; git commit -m"committed all"` * edit files * run `prove -l t` to run non-regression tests * run `git diff` and send the output the [author](mailto:ddumont@cpan.org) ## Provide feedback ## Feedback is important. Please take a moment to rate, comment or add stars to this project: * [cme github](https://github.com/dod38fr/cme-perl) or [cme cpan ratings](http://cpanratings.perl.org/rate/?distribution=App-Cme) * [config-model github](https://github.com/dod38fr/config-model) or [config-model cpan ratings](http://cpanratings.perl.org/rate/?distribution=Config::Model) Config-Model-2.149/MANIFEST.SKIP0000644000175000017500000000016514170053137014337 0ustar domidomi^debian/ ~$ \.ptkdb$ \.old$ dist.ini libconfig _build \.orig$ ^MYMETA.yml$ blib wr_root \.rej$ README.build-from-git Config-Model-2.149/Build.PL0000644000175000017500000001044514170053137013737 0ustar domidomi# # This file is part of Config-Model # # This software is Copyright (c) 2005-2022 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' => '4.002', 'Config::Model::Tester::Setup' => '0', 'File::Copy' => '0', 'File::Spec' => '0', 'IO::File' => '0', 'Module::Build' => '0.34', 'Test::Differences' => '0', 'Test::Exception' => '0', 'Test::File::Contents' => '0', 'Test::Log::Log4perl' => '0', 'Test::Memory::Cycle' => '0', 'Test::More' => '0', 'Test::Perl::Critic' => '0', 'Test::Pod' => '1.00', 'Test::Warn' => '0.11', 'boolean' => '0', 'lib' => '0' }, 'configure_requires' => { 'Module::Build' => '0.34' }, 'recommends' => { 'Fuse' => '0', 'Term::ReadLine' => '0', 'Text::Levenshtein::Damerau' => '0' }, 'requires' => { 'Carp' => '0', 'Carp::Assert::More' => '0', 'Cwd' => '0', 'Data::Dumper' => '0', 'Encode' => '0', 'English' => '0', 'Fcntl' => '0', 'File::HomeDir' => '0', 'File::Path' => '0', 'Hash::Merge' => '0.12', 'JSON' => '0', 'List::MoreUtils' => '0', 'List::Util' => '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.070', 'Pod::POM' => '0', 'Pod::Simple' => '3.23', 'Pod::Text' => '0', 'Regexp::Common' => '0', 'Scalar::Util' => '0', 'Storable' => '0', 'Text::Levenshtein::Damerau' => '0', 'Text::Wrap' => '0', 'YAML::Tiny' => '0', 'base' => '0', 'feature' => '0', 'open' => '0', 'overload' => '0', 'parent' => '0', 'perl' => 'v5.20.0', 'strict' => '0', 'utf8' => '0', 'vars' => '0', 'warnings' => '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 wr_root_p/ ], ); $build->add_build_element('pl'); $build->add_build_element('conf'); $build->add_build_element('appli'); $build->create_build_script; Config-Model-2.149/lib/0000755000175000017500000000000014170053137013205 5ustar domidomiConfig-Model-2.149/lib/Config/0000755000175000017500000000000014170053137014412 5ustar domidomiConfig-Model-2.149/lib/Config/Model/0000755000175000017500000000000014170053137015452 5ustar domidomiConfig-Model-2.149/lib/Config/Model/ValueComputer.pm0000644000175000017500000007112014170053137020604 0ustar domidomi# # This file is part of Config-Model # # This software is Copyright (c) 2005-2022 by Dominique Dumont. # # This is free software, licensed under: # # The GNU Lesser General Public License, Version 2.1, February 1999 # package Config::Model::ValueComputer 2.149; 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); use feature qw/postderef signatures/; no warnings qw/experimental::postderef experimental::signatures/; 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, handles => [qw/grab grab_value location index element/], ); 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; return 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->trace("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->trace("pre_formula: ". ($result_r ? $$result_r : ' pre_compute failed, using original formula')); $self->{pre_formula} = $result_r ? $$result_r : $self->{formula}; return; } sub compute ($self, %args) { my $check = $args{check} || 'yes'; my $pre_formula = $self->{pre_formula}; $logger->trace("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->trace("will use eval"); my $all_defined = 1; my %__vars; 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 : '' ) ); # security: $v are stored in %__vars hash, so they are # used by eval'ed code, but not directly eval'ed if ( defined $v ) { $__vars{$key} = $v } else { $all_defined = 0; } } if ($all_defined) { my $formula = $pre_formula; $formula =~ s/\$([_a-zA-Z]\w*)/defined $__vars{$1} ? "\$__vars{$1}" : "\$$1" /eg; $logger->debug("compute: evaluating '$formula'"); $result = eval $formula; ## no critic (ProhibitStringyEval) 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->trace("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 ($self, %args) { my $check = $args{check} || 'yes'; $logger->trace("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; if (%$variables) { $str .= ", where "; foreach my $k ( sort keys %$variables ) { my $u_val = $variables->{$k}; if ( ref($u_val) ) { foreach (sort keys %$u_val) { $str .= "\n\t\t'\$$k" . "{$_} is converted to '$orig_variables->{$k}{$_}'"; } } 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 ($self, %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->trace( "called on variables '", join( "', '", sort keys %variables ), "'" ) if $logger->is_trace; # 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->trace("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->trace("key '$key', pre res '$$pre_res_r', left $var_left\n"); $variables{$key} = $$pre_res_r; $logger->trace( "variable after pre_compute: ", join( " ", keys %variables ) ) if $logger->is_trace; 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->trace( "variable after compute: ", join( " ", keys %variables ) ) if $logger->is_trace; } { no warnings "uninitialized"; ## no critic (TestingAndDebugging::ProhibitNoWarnings) $logger->trace("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->trace("done"); return \%variables; } sub _pre_replace { my ( $replace_h, $pre_value ) = @_; $logger->trace("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_trace ) { my $str = defined $value ? $value : ''; $logger->trace("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->trace("handling &$function($up) "); my $target = $value_object->eval_function($function, $up, $check); $return = \$target ; # 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->trace("_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 : '', "'" ); } # 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 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.149 =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( steps => '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)> or C<&index(- -)> or C<&index(- - -)> =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 is 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 Compute variables are a set of C<< key => value >> pairs that define the variables used in the specified formula. The key is a variable name used in the string that represents the formula. The value is a string that is used to get the correct L 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. The function C<&index> C<&element> and C<&location> are also allowed. =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 is 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 yields an undefined value if one variable is undefined. You may change this behavior with C parameter. With this parameter, you can specify a "fallback" value that is used in your formula instead of an undefined variable. The most useful fallback values are: undef_is => "''", # for string values undef_is => 0 , # for integers, boolean values Example: Source => { type => 'leaf', value_type => 'string', mandatory => 1, migrate_from => { use_eval => 1, formula => '$old || $older ;', undef_is => "''", variables => { older => '- Original-Source-Location', old => '- Upstream-Source' } }, }, [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 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 short: '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-2022 by Dominique Dumont. This is free software, licensed under: The GNU Lesser General Public License, Version 2.1, February 1999 =cut Config-Model-2.149/lib/Config/Model/Dumper.pm0000644000175000017500000002611114170053137017245 0ustar domidomi# # This file is part of Config-Model # # This software is Copyright (c) 2005-2022 by Dominique Dumont. # # This is free software, licensed under: # # The GNU Lesser General Public License, Version 2.1, February 1999 # package Config::Model::Dumper 2.149; use Carp; use strict; use warnings; use Config::Model::Exception; use Config::Model::ObjTreeScanner; use Config::Model::Value; sub new { bless {}, shift; } sub quote { _quote( qr/[\s~"#*]/, @_ ); } sub id_quote { _quote( qr/[\s~"@*<>.=#]/, @_ ); } sub _quote { my ( $re, @res ) = @_; foreach (@res) { if ( defined $_ and ( /$re/ or $_ eq '' ) ) { s/"/\\"/g; # escape present quotes $_ = '"' . $_ . '"'; # add my quotes } } return wantarray ? @res : $res[0]; } sub note_quote { my @res = @_; foreach (@res) { if ( defined $_ and $_ and (/(\s|"|\*)/) ) { s/"/\\"/g; # escape present quotes $_ = '"' . $_ . '"'; # add my quotes } } return wantarray ? @res : $res[0]; } sub dump_tree { my $self = shift; my %args = @_; my $full = delete $args{full_dump} || 0; my $skip_aw = delete $args{skip_auto_write} || ''; my $auto_v = delete $args{auto_vivify} || 0; my $mode = delete $args{mode} || ''; if ($full) { carp "dump_tree: full_dump parameter is deprecated, please use mode => 'user'"; } my $check = delete $args{check} || 'yes'; if ( $check !~ /yes|no|skip/ ) { croak "dump_tree: unexpected 'check' value: $check"; } # mode parameter is slightly different from fetch's mode my $fetch_mode = $full ? 'user' : $mode eq 'full' ? 'user' : $mode ? $mode : 'custom'; if ( my $err = Config::Model::Value->is_bad_mode($fetch_mode) ) { croak "dump_tree: $err"; } my $node = delete $args{node} || croak "dump_tree: missing 'node' parameter"; my $compute_pad = sub { my $depth = 0; my $obj = shift; while ( defined $obj->parent ) { $depth++; $obj = $obj->parent; } return ' ' x $depth; }; my $leaf_cb = sub { my ( $scanner, $data_r, $node, $element, $index, $value_obj ) = @_; # get value or only customized value my $value = quote( $value_obj->fetch( mode => $fetch_mode, check => $check ) ); $index = id_quote($index); my $pad = $compute_pad->($node); my $name = defined $index ? "$element:$index" : $element; # add annotation for obj contained in hash or list my $note = note_quote( $value_obj->annotation ); $$data_r .= "\n" . $pad . $name if defined $value or $note; if (defined $value) { $value =~ s/\\n/\\\\n/g; $$data_r .= '=' . $value; } $$data_r .= '#' . $note if $note; }; my $check_list_cb = sub { my ( $scanner, $data_r, $node, $element, $index, $value_obj ) = @_; # get value or only customized value my $value = $value_obj->fetch( mode => $fetch_mode, check => $check ); my $qvalue = quote($value); $index = id_quote($index); my $pad = $compute_pad->($node); my $name = defined $index ? "$element:$index" : $element; # add annotation for obj contained in hash or list my $note = note_quote( $value_obj->annotation ); $$data_r .= "\n" . $pad . $name if $value or $note; $$data_r .= '=' . $qvalue if $value; $$data_r .= '#' . $note if $note; }; my $list_element_cb = sub { my ( $scanner, $data_r, $node, $element, @keys ) = @_; my $pad = $compute_pad->($node); my $list_obj = $node->fetch_element($element); # add annotation for list element my $list_note = note_quote( $list_obj->annotation ); $$data_r .= "\n$pad$element#$list_note" if $list_note; if ( $list_obj->cargo_type eq 'node' ) { foreach my $k (@keys) { $scanner->scan_list( $data_r, $node, $element, $k ); } } else { # write value comments foreach my $idx ( $list_obj->fetch_all_indexes ) { my $note = $list_obj->fetch_with_id($idx)->annotation; $$data_r .= "\n$pad$element:$idx#" . note_quote($note) if $note; } # skip undef values my @val = id_quote( grep { defined $_ } $list_obj->fetch_all_values(mode => $fetch_mode, check => $check) ); $$data_r .= "\n$pad$element:=" . join( ',', @val ) if @val; } }; my $hash_element_cb = sub { my ( $scanner, $data_r, $node, $element, @keys ) = @_; my $pad = $compute_pad->($node); my $hash_obj = $node->fetch_element($element); # add annotation for list or hash element my $note = note_quote( $hash_obj->annotation ); $$data_r .= "\n$pad$element#$note" if $note; # resume exploration map { $scanner->scan_hash( $data_r, $node, $element, $_ ); } @keys; }; # called for nodes contained in nodes (not root). # This node can be held by a plain element or a hash element or a list element my $node_element_cb = sub { my ( $scanner, $data_r, $node, $element, $key, $contained_node ) = @_; my $type = $node->element_type($element); return if $skip_aw and $contained_node->is_auto_write_for_type($skip_aw); my $pad = $compute_pad->($node); my $elt = $node->fetch_element($element); # load string can feature only one comment per element_type # ie foo#comment foo:bar#comment foo:bar=val#comment are fine # but foo#comment:bar if not valid -> foo#commaent foo:bar my $head = "\n$pad$element"; my $node_note = note_quote( $contained_node->annotation ); if ( $type eq 'list' or $type eq 'hash' ) { $head .= ':' . id_quote($key); $head .= '#' . $node_note if $node_note; my $sub_data = ''; $scanner->scan_node( \$sub_data, $contained_node ); $$data_r .= $head . $sub_data . ' -'; } else { $head .= '#' . $node_note if $node_note; my $sub_data = ''; $scanner->scan_node( \$sub_data, $contained_node ); # skip simple nodes that do not bring data $$data_r .= $head . $sub_data . ' -' if $sub_data; } }; my @scan_args = ( fallback => 'all', auto_vivify => $auto_v, list_element_cb => $list_element_cb, hash_element_cb => $hash_element_cb, leaf_cb => $leaf_cb, node_element_cb => $node_element_cb, check_list_element_cb => $check_list_cb, check => $check, ); my @left = keys %args; croak "Dumper: unknown parameter:@left" if @left; # perform the scan my $view_scanner = Config::Model::ObjTreeScanner->new(@scan_args); my $ret = ''; my $root_note = note_quote( $node->annotation ); $ret .= "\n#$root_note" if $root_note; $view_scanner->scan_node( \$ret, $node ); substr( $ret, 0, 1, '' ); # remove leading \n $ret .= ' -' if $ret; return $ret . "\n"; } 1; # ABSTRACT: Serialize data of config tree __END__ =pod =encoding UTF-8 =head1 NAME Config::Model::Dumper - Serialize data of config tree =head1 VERSION version 2.149 =head1 SYNOPSIS use Config::Model ; # define configuration tree object my $model = Config::Model->new ; $model ->create_config_class ( name => "MyClass", element => [ [qw/foo bar/] => { type => 'leaf', value_type => 'string' }, baz => { type => 'hash', index_type => 'string' , cargo => { type => 'leaf', value_type => 'string', }, }, ], ) ; my $inst = $model->instance(root_class_name => 'MyClass' ); my $root = $inst->config_root ; # put some data in config tree the hard way $root->fetch_element('foo')->store('yada') ; $root->fetch_element('bar')->store('bla bla') ; $root->fetch_element('baz')->fetch_with_id('en')->store('hello') ; # put more data the easy way my $steps = 'baz:fr=bonjour baz:hr="dobar dan"'; $root->load( steps => $steps ) ; # dump only customized data print $root->dump_tree; =head1 DESCRIPTION This module is used directly by L to serialize configuration data in a compact (but readable) string. The serialization can be done in standard mode where only customized values are dumped in the string. I.e. only data modified by the user are dumped. All other mode supported by L can be used, for instance, to get default values. The serialized string can be used by L to store the data back into a configuration tree. Note that undefined values are skipped for list element. I.e. if a list element contains C<('a',undef,'b')>, the dump then contains C<'a','b'>. =head1 CONSTRUCTOR =head2 new No parameter. The constructor should be used only by L. =head1 Methods =head2 dump_tree Return a string that contains a dump of the object tree with all the values. This string follows the convention defined by L. The serialized string can be used by L to store the data back into a configuration tree. Parameters are: =over =item mode C dumps all configuration data including default values. All mode values from L can be used. By default, the dump contains only data modified by the user (i.e. C data that differ from default or preset values). =item node Reference to the L object that is dumped. All nodes and leaves attached to this node are also dumped. =item skip_auto_write ( ) Skip node that have a write capability matching C in their model. See L. This option must be used when using Dumper to write back configuration data. When a configuration model contains several backends (one at the tree root and others in tree nodes), setting this option ensure that the "root" configuration file does not contain data duplicated in configuration file of others tree nodes. =item auto_vivify Scan and create data for nodes elements even if no actual data was stored in them. This may be useful to trap missing mandatory values. (default: 0) =item check Check value before dumping. Valid check are 'yes', 'no' and 'skip'. =back =head1 AUTHOR Dominique Dumont, (ddumont at cpan dot org) =head1 SEE ALSO L,L,L =head1 AUTHOR Dominique Dumont =head1 COPYRIGHT AND LICENSE This software is Copyright (c) 2005-2022 by Dominique Dumont. This is free software, licensed under: The GNU Lesser General Public License, Version 2.1, February 1999 =cut Config-Model-2.149/lib/Config/Model/SimpleUI.pm0000644000175000017500000003476314170053137017514 0ustar domidomi# # This file is part of Config-Model # # This software is Copyright (c) 2005-2022 by Dominique Dumont. # # This is free software, licensed under: # # The GNU Lesser General Public License, Version 2.1, February 1999 # package Config::Model::SimpleUI 2.149; use Carp; use v5.020; use strict; use warnings; use open qw(:std :utf8); # undeclared streams in UTF-8 use Encode qw(decode_utf8); use Regexp::Common qw/delimited/; use feature qw/postderef signatures/; no warnings qw/experimental::postderef experimental::signatures/; 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 content of object (args: path and/or filter pattern) ls -> show elements of current node ls foo* -> shows element matching foo.* ls \'foo*\' -> shows elements of node stored in "foo*" ls aHash -> shows keys of Hash ls \'aHash:"*"\' -> shows elements of node stored in key "*" of "aHash" hash ll [-nz] [-v] [ element | pattern ] -> show elements of current node and their value (options: -nz → hides empty value, -v → verbose) (args: element name or filter pattern) info -> show detailed information on object or current node (args: optional path to object) tree -> show configuration tree from an object or current node (args: optional path to object) 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 check [elt] -> run check current on current node or elt fix [ ! | elt ] -> fix warnings in current node or of specified element or on all tree (with ! arg) 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->get_type() eq 'node' ) { my $type = $obj->element_type($item); my $elt = $obj->fetch_element($item); my $help = $obj->get_help_as_text($item); $res .= "element $item (type $type)"; $res .= ": " if $help; $res .= "\n" if $help =~ /\n/ or length($help) > 40 ; $res .= $help . "\n" if $help; if ( $type eq 'leaf' and $elt->value_type eq 'enum' ) { $res .= " possible values: " . join( ', ', $elt->get_choice ) . "\n"; } } } } else { $res = $obj->get_help_as_text(); } return $res; }; my $ll_sub = sub { my $self = shift; my @raw_args = @_; my @desc_opt = qw/check no/; my %opt = map { /^-(\w+)/ ? ($1 => 1) : () } @raw_args; push @desc_opt, hide_empty => 1 if $opt{nz} ; push @desc_opt, verbose => 1 if $opt{v} ; my @args = grep {! /^-/ } @raw_args; push @args, '*' unless @args; # default action is to list all elements my $obj = $self->{current_node}; for (@args) {s/\*/.*/g;} ; my $pattern = join ('|',@args); return $obj->describe( pattern => qr/^$pattern$/, @desc_opt ); }; 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; if (@_) { $self->{current_node}->load(join('',@_)); } else { say "No command given."; } return ""; }, display => sub ($self, @args) { unless (@args) { say "Nothing to display"; return; } return $self->{current_node}->grab_value(@args); }, info => sub { my $self = shift; my $cnode = $self->{current_node}; my $target = @_ ? $cnode->grab(steps => [@_]) : $cnode; return join("\n", $target->get_info ); }, ls => sub { my $self = shift; my $target = $self->{current_node}; my $pattern = '*'; for (@_) { if (/\*/ and not /^["']/) { $pattern = $_; last; } $target = $target->grab(steps => $_); } $pattern =~ s/\*/.*/g; my $i = $self->{current_node}->instance; my @res = $target->can('children') ? grep {/^$pattern$/} $target->children : (); return join( ' ', @res ); }, tree => sub { my $self = shift; my $i = $self->{current_node}->instance; my $cnode = $self->{current_node}; my $target = @_ ? $cnode->grab(steps => [@_]) : $cnode; my @res = $target->dump_tree( mode => 'user' ); 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 ''; }, check => sub { my ( $self, $elt_name ) = @_; if ($elt_name) { $self->{current_node}->fetch_element($elt_name)->check(); } else { $self->{current_node}->check; } return ''; }, fix => sub { my ( $self, $elt_name ) = @_; if ($elt_name eq '!') { $self->{root}->instance->apply_fixes; } elsif ($elt_name) { $self->{current_node}->fetch_element($elt_name)->apply_fixes; } else { $self->{current_node}->apply_fixes; } return ''; }, 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 { my @cmds = sort keys %run_dispatch; return @cmds; } 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 ) { if ($instance->has_changes) { $instance->say_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/; my $re = $RE{delimited}{-delim=>q{'"}}; my ( $action, @args ) = ( $user_cmd =~ /((?:[^\s"']|$re)+)/g ); if ( defined $run_dispatch{$action} ) { my $res; my $ok = eval { $res = $run_dispatch{$action}->( $self, @args ); 1; }; say $@->message unless $ok; 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.149 =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 $steps = 'foo=FOO hash_of_nodes:fr foo=bonjour - hash_of_nodes:en foo=hello '; $root->load( steps => $steps ); 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 dumps 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 [path] [ pattern ] Show elements of current node or of a node pointed by path. Elements can be filtered with a shell pattern. See inline help for more details. =item ll [-nz] [-v] [ pattern ... ] Describe elements of current node. Can be used with shell patterns or element names. Skip empty element with C<-nz> option. Display more information with C<-v> option =item tree [path] Show configuration tree from current node or of a node pointed by path. =item info [path] Show debug information on current node or on the element pointed by path. The debug information may show model parametersm default or computed values. =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 check Without parameter, show warnings starting from current node. With an element name as parameter, do the same on the element. =item fix Try to fix warning starting from current node. With an element name as parameter, do the same on the element. With "C" as parameter, try to fix warnings starting from root node by calling L there. =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-2022 by Dominique Dumont. This is free software, licensed under: The GNU Lesser General Public License, Version 2.1, February 1999 =cut Config-Model-2.149/lib/Config/Model/CheckList.pm0000644000175000017500000010440414170053137017664 0ustar domidomi# # This file is part of Config-Model # # This software is Copyright (c) 2005-2022 by Dominique Dumont. # # This is free software, licensed under: # # The GNU Lesser General Public License, Version 2.1, February 1999 # package Config::Model::CheckList 2.149; use Mouse; use 5.010; use Config::Model::Exception; use Config::Model::IdElementReference; use Config::Model::Warper; use List::MoreUtils qw/any none/; use Carp; use Log::Log4perl qw(get_logger :levels); use Storable qw/dclone/; extends qw/Config::Model::AnyThing/; with "Config::Model::Role::WarpMaster"; with "Config::Model::Role::Grab"; with "Config::Model::Role::HelpAsText"; with "Config::Model::Role::ComputeFunction"; my $logger = get_logger("Tree.Element.CheckList"); my $user_logger = get_logger("User"); my @introspect_params = qw/refer_to computed_refer_to/; my @accessible_params = qw/default_list upstream_default_list choice ordered/; my @allowed_warp_params = ( @accessible_params, qw/level/ ); has [qw/backup data preset layered/] => ( is => 'rw', isa => 'HashRef', default => sub { {}; } ); has computed_refer_to => ( is => 'rw', isa => 'Maybe[HashRef]' ); has [qw/refer_to/] => ( is => 'rw', isa => 'Str' ); has [qw/ordered_data choice/] => ( is => 'rw', isa => 'ArrayRef', default => sub { []; } ); has [qw/ordered/] => ( is => 'ro', isa => 'Bool' ); has [qw/warp help/] => ( is => 'rw', isa => 'Maybe[HashRef]' ); around BUILDARGS => sub { my $orig = shift; my $class = shift; my %args = @_; my %h = map { ( $_ => $args{$_} ); } grep { defined $args{$_} } @allowed_warp_params; return $class->$orig( backup => dclone( \%h ), @_ ); }; sub BUILD { my $self = shift; if ( defined $self->refer_to or defined $self->computed_refer_to ) { $self->submit_to_refer_to(); } $self->set_properties(); # set will use backup data if ( defined $self->warp ) { my $warp_info = $self->warp; $self->{warper} = Config::Model::Warper->new( warped_object => $self, %$warp_info, allowed => \@allowed_warp_params ); } $self->cl_init; $logger->info( "Created check_list element " . $self->element_name ); return $self; } sub cl_init { my $self = shift; $self->warp if ( $self->{warp} ); if ( defined $self->{ref_object} ) { my $level = $self->parent->get_element_property( element => $self->{element_name}, property => 'level', ); $self->{ref_object}->get_choice_from_referred_to if $level ne 'hidden'; } } sub name { my $self = shift; my $name = $self->{parent}->name . ' ' . $self->{element_name}; return $name; } sub value_type { return 'check_list'; } # warning : call to 'set' are not cumulative. Default value are always # restored. Lest keeping track of what was modified with 'set' is # too hard for the user. sub set_properties { my $self = shift; # cleanup all parameters that are handled by warp for (@allowed_warp_params) { delete $self->{$_}, } if ( $logger->is_trace() ) { my %h = @_; my $keys = join( ',', keys %h ); $logger->trace("set_properties called on $self->{element_name} with $keys"); } # merge data passed to the constructor with data passed to set my %args = ( %{ $self->{backup} }, @_ ); # these are handled by Node or Warper for (qw/level/) { delete $args{$_} } $self->{ordered} = delete $args{ordered} || 0; if ( defined $args{choice} ) { my @choice = @{ delete $args{choice} }; $self->{default_choice} = \@choice; $self->setup_choice(@choice); } if ( defined $args{default} ) { $logger->warn($self->name, ": default param is deprecated, use default_list"); $args{default_list} = delete $args{default}; } if ( defined $args{default_list} ) { $self->{default_list} = delete $args{default_list}; } # store default data in a hash (more convenient) $self->{default_data} = { map { $_ => 1 } @{ $self->{default_list} } }; if ( defined $args{upstream_default_list} ) { $self->{upstream_default_list} = delete $args{upstream_default_list}; } # store upstream default data in a hash (more convenient) $self->{upstream_default_data} = { map { $_ => 1 } @{ $self->{upstream_default_list} } }; Config::Model::Exception::Model->throw( object => $self, error => "Unexpected parameters :" . join( ' ', keys %args ) ) if scalar keys %args; if ( $self->has_warped_slaves ) { my $hash = $self->get_checked_list_as_hash; # force scalar context $self->trigger_warp($hash, $self->fetch); } } sub setup_choice { my $self = shift; my @choice = ref $_[0] ? @{ $_[0] } : @_; $logger->trace("CheckList $self->{element_name}: setup_choice with @choice"); # store all enum values in a hash. This way, checking # whether a value is present in the enum set is easier delete $self->{choice_hash} if defined $self->{choice_hash}; for (@choice) { $self->{choice_hash}{$_} = 1; } $self->{choice} = \@choice; # cleanup current preset and data if it does not fit current choices foreach my $field (qw/preset data layered/) { next unless defined $self->{$field}; # do not create if not present foreach my $item ( keys %{ $self->{$field} } ) { delete $self->{$field}{$item} unless defined $self->{choice_hash}{$item}; } } } # Need to extract Config::Model::Reference (used by Value, and maybe AnyId). sub submit_to_refer_to { my $self = shift; if ( defined $self->refer_to ) { $self->{ref_object} = Config::Model::IdElementReference->new( refer_to => $self->refer_to, config_elt => $self, ); } elsif ( defined $self->computed_refer_to ) { $self->{ref_object} = Config::Model::IdElementReference->new( computed_refer_to => $self->computed_refer_to, config_elt => $self, ); my $var = $self->{computed_refer_to}{variables}; # refer_to registration is done for all element that are used as # variable for complex reference (ie '- $foo' , {foo => '- bar'} ) foreach my $path ( values %$var ) { # is ref during test case #print "path is '$path'\n"; next if $path =~ /\$/; # next if path also contain a variable my $master = $self->grab($path); next unless $master->can('register_dependency'); $master->register_dependency($self); } } else { croak "checklist submit_to_refer_to: undefined refer_to or computed_refer_to"; } } sub setup_reference_choice { my $self = shift; $self->setup_choice(@_); } sub get_type { my $self = shift; return 'check_list'; } sub get_cargo_type { goto &cargo_type } sub cargo_type { my $self = shift; return 'leaf'; } sub apply_fixes { # no operation. THere's no check_value method because a check list # supposed to be always correct. Hence apply_fixes is empty. } sub notify_change { my $self = shift; my %args = @_; return if $self->instance->initial_load and not $args{really}; $self->SUPER::notify_change( %args, value_type => $self->value_type ); # shake all warped or computed objects that depends on me foreach my $s ( $self->get_warped_slaves ) { $logger->debug( "calling notify_change on slave ", $s->name ) if $logger->is_debug; $s->needs_check(1); } } # does not check the validity, but check the item of the check_list sub check { my $self = shift; my @list = ref $_[0] eq 'ARRAY' ? @{ $_[0] } : @_; my %args = ref $_[0] eq 'ARRAY' ? @_[ 1, $#_ ] : ( check => 'yes' ); my $check = $self->_check_check( $args{check} ); if ( defined $self->{ref_object} ) { $self->{ref_object}->get_choice_from_referred_to; } my @changed; for (@list) { push @changed, $_ if $self->_store( $_, 1, $check ) } $self->notify_change( note => "check @changed" ) unless $self->instance->initial_load; } sub clear_item { my $self = shift; my $choice = shift; my $inst = $self->instance; my $data_name = $inst->preset ? 'preset' : $inst->layered ? 'layered' : 'data'; my $old_v = $self->{$data_name}{$choice}; my $changed = 0; if ($old_v) { $changed = 1; } delete $self->{$data_name}{$choice}; if ( $self->{ordered} and $changed ) { my $ord = $self->{ordered_data}; my @new = grep { $_ ne $choice } @$ord; $self->{ordered_data} = \@new; } return $changed; } # internal sub _store { my ( $self, $choice, $value, $check ) = @_; my $inst = $self->instance; if ( $value != 0 and $value != 1 ) { Config::Model::Exception::WrongValue->throw( error => "store: check item value must be boolean, " . "not '$value'.", object => $self ); return; } my $ok = $self->{choice_hash}{$choice} || 0; my $changed = 0; if ($ok) { my $data_name = $inst->preset ? 'preset' : $inst->layered ? 'layered' : 'data'; my $old_v = $self->{$data_name}{$choice} ; if ( not defined $old_v or $old_v ne $value ) { # no change notif when going from undef to 0 as the # logical value does not change { no warnings qw/uninitialized/; $changed = (!$old_v xor !$value); } $self->{$data_name}{$choice} = $value; } if ( $self->{ordered} and $value ) { my $ord = $self->{ordered_data}; push @$ord, $choice unless scalar grep { $choice eq $_ } @$ord; } } else { my $err_str = "Unknown check_list item '$choice'. Expected '" . join( "', '", @{ $self->{choice} } ) . "'"; $err_str .= "\n\t" . $self->{ref_object}->reference_info if defined $self->{ref_object}; if ($check eq 'yes') { Config::Model::Exception::WrongValue->throw( error => $err_str, object => $self ); } elsif ($check eq 'skip') { $user_logger->warn($err_str); } } if ( $ok and $changed and $self->has_warped_slaves and not( $self->instance->layered or $self->instance->preset ) ) { my $h = $self->get_checked_list_as_hash; my $str = $self->fetch; $self->trigger_warp($h , $str); } return $changed; } sub get_arguments { my $self = shift; my $arg = shift; my @list = ref $arg eq 'ARRAY' ? @$arg : ($arg, @_); my %args = ref $arg eq 'ARRAY' ? ( check => 'yes', @_ ) : (check => 'yes'); my $check = $self->_check_check( $args{check} ); return \@list, $check, \%args; } sub uncheck { my $self = shift; my ($list, $check) = $self->get_arguments(@_); if ( defined $self->{ref_object} ) { $self->{ref_object}->get_choice_from_referred_to; } my @changed; for ( @$list ) { push @changed, $_ if $self->_store( $_, 0, $check ) } $self->notify_change( note => "uncheck @changed" ) unless $self->instance->initial_load; } sub has_data { my $self = shift; my @set = $self->get_checked_list(qw/mode custom/) ; return scalar @set; } { my %accept_mode = map { ( $_ => 1 ) } qw/custom standard preset default layered upstream_default non_upstream_default user backend/; sub is_bad_mode { my ($self, $mode) = @_; if ( $mode and not defined $accept_mode{$mode} ) { my $good_ones = join( ' or ', sort keys %accept_mode ); return "expected $good_ones as mode parameter, not $mode"; } } } sub is_checked { my $self = shift; my $choice = shift; my %args = @_; my $mode = $args{mode} || ''; my $check = $self->_check_check( $args{check} ); my $ok = $self->{choice_hash}{$choice} || 0; if ($ok) { if ( my $err = $self->is_bad_mode($mode) ) { croak "is_checked: $err"; } my $dat = $self->{data}{$choice}; my $pre = $self->{preset}{$choice}; my $def = $self->{default_data}{$choice}; my $ud = $self->{upstream_default_data}{$choice}; my $lay = $self->{layered}{$choice}; my $std_v = $pre // $def // 0; my $non_up_def = $dat // $pre // $lay // $def // 0; my $user_v = $dat // $pre // $lay // $def // $ud // 0; my $result = $mode eq 'custom' ? ( $dat && !$std_v ? 1 : 0 ) : $mode eq 'preset' ? $pre : $mode eq 'layered' ? $lay : $mode eq 'upstream_default' ? $ud : $mode eq 'default' ? $def : $mode eq 'standard' ? $std_v : $mode eq 'non_upstream_default' ? $ud : $mode eq 'user' ? $user_v : $mode eq 'backend' ? $dat // $std_v : $dat // $std_v; return $result; } elsif ( $check eq 'yes' ) { my $err_str = "Unknown check_list item '$choice'. Expected '" . join( "', '", @{ $self->{choice} } ) . "'"; $err_str .= "\n\t" . $self->{ref_object}->reference_info if defined $self->{ref_object}; Config::Model::Exception::WrongValue->throw( error => $err_str, object => $self ); } } # get_choice is always called when using check_list, so having a # warp safety check here makes sense sub get_choice { my $self = shift; if ( defined $self->{ref_object} ) { $self->{ref_object}->get_choice_from_referred_to; } if ( not defined $self->{choice} ) { my $msg = "check_list element has no defined choice. " . $self->warp_error; Config::Model::Exception::UnavailableElement->throw( info => $msg, object => $self->parent, element => $self->element_name, ); } return @{ $self->{choice} }; } sub get_default_choice { my $self = shift; return @{ $self->{default_choice} || [] }; } sub get_builtin_choice { carp "get_builtin_choice is deprecated, use get_upstream_default_choice"; goto &get_upstream_default_choice; } sub get_upstream_default_choice { my $self = shift; return @{ $self->{upstream_default_data} || [] }; } sub get_help { my $self = shift; my $help = $self->{help}; return $help unless @_; my $on_value = shift; return $help->{$on_value} if defined $help and defined $on_value; return; } sub get_info { my $self = shift; my @items = ('type: check_list'); if ( defined $self->refer_to ) { push @items, "refer_to: " . $self->refer_to; } push @items, "ordered: " . ( $self->ordered ? 'yes' : 'no' ); return @items; } sub clear { my $self = shift; # also triggers notify changes for ($self->get_choice) { $self->clear_item($_) } } sub clear_values { goto &clear; } sub clear_layered { my $self = shift; $self->{layered} = {}; } my %old_mode = ( built_in_list => 'upstream_default_list', ); sub get_checked_list_as_hash { my $self = shift; my %args = @_ > 1 ? @_ : ( mode => $_[0] ); my $mode = $args{mode} || ''; foreach my $k ( keys %old_mode ) { next unless $mode eq $k; $mode = $old_mode{$k}; carp $self->location, " warning: deprecated mode parameter: $k, ", "expected $mode\n"; } if ( my $err = $self->is_bad_mode($mode)) { croak "get_checked_list_as_hash: $err"; } my $dat = $self->{data}; my $pre = $self->{preset}; my $def = $self->{default_data}; my $lay = $self->{layered}; my $ud = $self->{upstream_default_data}; # fill empty hash result my %h = map { $_ => 0 } $self->get_choice; my %predef = ( %$def, %$pre ); my %std = ( %$ud, %$lay, %$def, %$pre ); # use _std_backup if all data values are null (no checked items by user) my %old_dat = ( none { $_; } values %$dat ) ? %{ $self->{_std_backup} || {} } : %$dat; if ( not $mode and any { $_; } values %predef and none { $_; } values %old_dat ) { # changed from nothing to default checked list that must be written $self->{_std_backup} = { %$def, %$pre }; $self->notify_change( note => "use default checklist" ); } # custom test must compare the whole list at once, not just one item at a time. my %result = $mode eq 'custom' ? ( ( grep { $dat->{$_} xor $std{$_} } keys %h ) ? ( %$pre, %$dat ) : () ) : $mode eq 'preset' ? (%$pre) : $mode eq 'layered' ? (%$lay) : $mode eq 'upstream_default' ? (%$ud) : $mode eq 'default' ? (%$def) : $mode eq 'standard' ? %std : $mode eq 'user' ? ( %h, %std, %$dat ) : ( %predef, %$dat ); return wantarray ? %result : \%result; } sub get_checked_list { my $self = shift; my %h = $self->get_checked_list_as_hash(@_); my @good_order = $self->{ordered} ? @{ $self->{ordered_data} } : sort keys %h; my @res = grep { $h{$_} } @good_order; return wantarray ? @res : \@res; } sub fetch { my $self = shift; return join( ',', $self->get_checked_list(@_) ); } sub fetch_custom { my $self = shift; return join( ',', $self->get_checked_list('custom') ); } sub fetch_preset { my $self = shift; return join( ',', $self->get_checked_list('preset') ); } sub fetch_layered { my $self = shift; return join( ',', $self->get_checked_list('layered') ); } sub get { my $self = shift; my $path = shift; if ($path) { Config::Model::Exception::User->throw( object => $self, message => "get() called with a value with non-empty path: '$path'" ); } return $self->fetch(@_); } sub set { my ($self, $path, $list, %args) = @_; my $check_validity = $self->_check_check( $args{check} ); if ($path) { Config::Model::Exception::User->throw( object => $self, message => "set() called with a value with non-empty path: '$path'" ); } my @list = split /,/, $list; return $self->set_checked_list( \@list, check => $check_validity ); } sub load { goto &store; } sub store { my $self = shift; my %args = @_ == 1 ? ( value => $_[0] ) : @_ == 3 ? ( 'value', @_ ) : @_; my $check_validity = $self->_check_check( $args{check} ); my @set = split /\s*,\s*/, $args{value}; foreach (@set) { s/^"|"$//g; s/\\"/"/g; } $self->set_checked_list(\@set, check => $check_validity); } sub store_set { goto &set_checked_list } sub set_checked_list { my $self = shift; my ($list, $check) = $self->get_arguments(@_); $logger->trace("called with @$list"); my %set = map { $_ => 1 } @$list; my @changed; foreach my $c ( $self->get_choice ) { my $v = delete $set{$c} // 0; push @changed, "$c:$v" if $self->_store( $c, $v, $check ); } # Items left in %set are unknown. _store will handle the error foreach my $item (keys %set) { $self->_store( $item, 1, $check ); } $self->{ordered_data} = $list; $self->notify_change( note => "set_checked_list @changed" ) if @changed and not $self->instance->initial_load; } sub set_checked_list_as_hash { my $self = shift; my %check_list = ref $_[0] eq 'HASH' ? %{ $_[0] } : @_; my %args = ref $_[0] eq 'HASH' ? @_[ 1, $#_ ] : ( check => 'yes' ); my $check_validity = $self->_check_check( $args{check} ); foreach my $c ( $self->get_choice ) { if ( defined $check_list{$c} ) { $self->_store( $c, $check_list{$c}, $check_validity ); } else { $self->clear_item($c); } } } sub load_data { my $self = shift; my %args = @_ > 1 ? @_ : ( data => shift ); my $data = $args{data}; my $check_validity = $self->_check_check( $args{check} ); if ( ref($data) eq 'ARRAY' ) { $self->set_checked_list($data, check => $check_validity); } elsif ( ref($data) eq 'HASH' ) { $self->set_checked_list_as_hash($data, check => $check_validity); } elsif ( not ref($data) ) { $self->set_checked_list([$data], check => $check_validity ); } else { Config::Model::Exception::LoadData->throw( object => $self, message => "check_list load_data called with unexpected type. ". "Expected plain scalar, array or hash ref", wrong_data => $data, ); } } sub swap { my ( $self, $a, $b ) = @_; foreach my $param ( $a, $b ) { unless ( $self->is_checked($param) ) { my $err_str = "swap: choice $param must be set"; Config::Model::Exception::WrongValue->throw( error => $err_str, object => $self ); } } # perform swap in ordered list foreach ( @{ $self->{ordered_data} } ) { if ( $_ eq $a ) { $_ = $b; } elsif ( $_ eq $b ) { $_ = $a; } } } sub move_up { my ( $self, $c ) = @_; unless ( $self->is_checked($c) ) { my $err_str = "swap: choice $c must be set"; Config::Model::Exception::WrongValue->throw( error => $err_str, object => $self ); } # perform move in ordered list my $list = $self->{ordered_data}; for ( my $i = 1 ; $i < @$list ; $i++ ) { if ( $list->[$i] eq $c ) { $list->[$i] = $list->[ $i - 1 ]; $list->[ $i - 1 ] = $c; last; } } } sub move_down { my ( $self, $c ) = @_; unless ( $self->is_checked($c) ) { my $err_str = "swap: choice $c must be set"; Config::Model::Exception::WrongValue->throw( error => $err_str, object => $self ); } # perform move in ordered list my $list = $self->{ordered_data}; for ( my $i = 0 ; $i + 1 < @$list ; $i++ ) { if ( $list->[$i] eq $c ) { $list->[$i] = $list->[ $i + 1 ]; $list->[ $i + 1 ] = $c; last; } } } # dummy to match Value call sub warning_msg { '' } 1; # ABSTRACT: Handle check list element __END__ =pod =encoding UTF-8 =head1 NAME Config::Model::CheckList - Handle check list element =head1 VERSION version 2.149 =head1 SYNOPSIS use Config::Model; # define configuration tree object my $model = Config::Model->new; $model->create_config_class( name => "MyClass", element => [ # type check_list uses Config::Model::CheckList my_check_list => { type => 'check_list', choice => [ 'A', 'B', 'C', 'D' ], help => { A => 'A effect is this', D => 'D does that', } }, ], ); my $inst = $model->instance( root_class_name => 'MyClass' ); my $root = $inst->config_root; # put data $root->load( steps => 'my_check_list=A' ); my $obj = $root->grab('my_check_list'); my $v = $root->grab_value('my_check_list'); print "check_list value '$v' with help '", $obj->get_help($v), "'\n"; # more data $obj->check('D'); $v = $root->grab_value('my_check_list'); print "check_list new value is '$v'\n"; # prints check_list new value is 'A,D' =head1 DESCRIPTION This class provides a check list element for a L. In other words, this class provides a list of booleans items. Each item can be set to 1 or 0. The available items in the check list can be : =over =item * A fixed list (with the C parameter) =item * A dynamic list where the available choice are the keys of another hash of the configuration tree. See L for details. =back =head1 CONSTRUCTOR CheckList object should not be created directly. =head1 CheckList model declaration A check list element must be declared with the following parameters: =over =item type Always C. =item choice A list ref containing the check list items (optional) =item refer_to This parameter is used when the keys of a hash are used to specify the possible choices of the check list. C point to a hash or list element in the configuration tree. See L for details. (optional) =item computed_refer_to Like C, but use a computed value to find the hash or list element in the configuration tree. See L for details. (optional) =item default_list List ref to specify the check list items which are "on" by default. (optional) =item ordered Specify whether the order of checked items must be preserved. =item help Hash ref to provide information on the check list items. =item warp Used to provide dynamic modifications of the check list properties See L for details =back For example: =over =item * A check list with help: choice_list => { type => 'check_list', choice => ['A' .. 'Z'], help => { A => 'A help', E => 'E help' } , }, =item * A check list with default values: choice_list_with_default => { type => 'check_list', choice => ['A' .. 'Z'], default_list => [ 'A', 'D' ], }, =item * A check list whose available choice and default change depending on the value of the C parameter: warped_choice_list => { type => 'check_list', warp => { follow => '- macro', rules => { AD => { choice => [ 'A' .. 'D' ], default_list => ['A', 'B' ] }, AH => { choice => [ 'A' .. 'H' ] }, } } }, =back =head1 Introspection methods The following methods returns the checklist parameter : =over =item refer_to =item computed_refer_to =back =head1 Choice reference The choice items of a check_list can be given by another configuration element. This other element can be: =over =item * The keys of a hash =item * Another checklist. In this case only the checked items of the other checklist are available. =back This other hash or other checklist is indicated by the C or C parameter. C uses the syntax of the C parameter of L See L. =head2 Reference examples =over =item * A check list where the available choices are the keys of C configuration parameter: refer_to_list => { type => 'check_list', refer_to => '- my_hash' }, =item * A check list where the available choices are the checked items of C configuration parameter: other_check_list => { type => 'check_list', choice => [qw/A B C/] }, refer_to_list => { type => 'check_list', refer_to => '- other_check_list' }, =item * A check list where the available choices are the keys of C and C and C configuration parameter: refer_to_3_lists => { type => 'check_list', refer_to => '- my_hash + - my_hash2 + - my_hash3' }, =item * A check list where the available choices are the specified choice and the choice of C and a hash whose name is specified by the value of the C configuration parameter (this example is admittedly convoluted): refer_to_check_list_and_choice => { type => 'check_list', computed_refer_to => { formula => '- refer_to_2_list + - $var', variables => { var => '- indirection ' } }, choice => [qw/A1 A2 A3/], }, =back =head1 Methods =head2 get_type Returns C. =head2 cargo_type Returns 'leaf'. =head2 check Set choice. Parameter is either a list of choices to set or a list ref and some optional parameter. I.e: check (\@list, check => 'skip') ; C parameter decide on behavior in case of invalid choice value: either die (if yes) or discard bad value (if skip) =head2 uncheck Unset choice. Parameter is either a list of choices to unset or a list ref and some optional parameter. I.e: uncheck (\@list, check => 'skip') ; C parameter decide on behavior in case of invalid choice value: either die (if yes) or discard bad value (if skip) =head2 is_checked Parameters: C<< ( choice, [ check => yes|skip ] , [ mode => ... ]) >> Return 1 if the given C was set. Returns 0 otherwise. C parameter decide on behavior in case of invalid choice value: either die (if yes) or discard bad value (if skip) C is either: custom standard preset default layered upstream_default =head2 has_data Return true if the check_list contains a set of checks different from default or upstream default set of check. =head2 get_choice Returns an array of all items names that can be checked (i.e. that can have value 0 or 1). =head2 get_help Parameters: C<(choice_value)> Return the help string on this choice value =head2 get_info Returns a list of information related to the check list. See L for more details. =head2 clear Reset the check list (can also be called as C) =head2 clear_item Parameters: C<(choice_value)> Reset an element of the checklist. =head2 get_checked_list_as_hash Accept a parameter (referred below as C parameter) similar to C in L. Returns a hash (or a hash ref) of all items. The boolean value is the value of the hash. Example: { A => 0, B => 1, C => 0 , D => 1} By default, this method returns all items set by the user, or items set in preset mode or checked by default. With a C parameter set to a value from the list below, this method returns: =over =item backend The value written in config file, (ie. set by user or by layered data or preset or default) =item custom The list entered by the user. An empty list is returned if the list of checked items is identical to the list of items checked by default. The whole list of checked items is returned as soon as B item is different from standard value. =item preset The list entered in preset mode =item standard The list set in preset mode or checked by default. =item default The default list (defined by the configuration model) =item layered The list specified in layered mode. =item upstream_default The list implemented by upstream project (defined in the configuration model) =item user The set that is active in the application. (ie. set by user or by layered data or preset or default or upstream_default) =item non_upstream_default The choice set by user or by layered data or preset or default. =back =head2 get_checked_list Parameters: C<< ( < mode > ) >> Returns a list (or a list ref) of all checked items (i.e. all items set to 1). =head2 fetch Parameters: C<< ( < mode > ) >> Returns a string listing the checked items (i.e. "A,B,C") =head2 get Parameters: C<< ( path [, < mode> ] ) >> Get a value from a directory like path. =head1 Method to check or clear items in the check list All these methods accept an optional C parameter that can be: =over =item yes A wrong item to check trigger an exception (default) =item skip A wrong item trigger a warning =item no A wrong item is ignored =back =head2 set Parameters: C<< ( path, items_to_set, [ check => [ yes | no | skip ] ] ) >> Set a checklist with a directory like path. Since a checklist is a leaf, the path should be empty. The values are a comma separated list of items to set in the check list. Example : $leaf->set('','A,C,Z'); $leaf->set('','A,C,Z', check => 'skip'); =head2 set_checked_list Set all passed items to checked (1). All other available items in the check list are set to 0. Example, for a check list that contains A B C and D check items: # set cl to A=0 B=1 C=0 D=1 $cl->set_checked_list('B','D') $cl->set_checked_list( [ 'B','D' ]) $cl->set_checked_list( [ 'B','D' ], check => 'yes') =head2 store_set Alias to L, so a list and a check_list can use the same store method =head2 store Set all items listed in a string to checked. The items must be separated by commas. All other available items in the check list are set to 0. Example: $cl->store('B, D') $cl->store( value => 'B,C' ) $cl->store( value => 'B,C', check => 'yes' ) =head2 load Alias to L. =head2 set_checked_list_as_hash Set check_list items. Missing items in the given hash of parameters are cleared (i.e. set to undef). Example for a check list containing A B C D $cl->set_checked_list_as_hash( { A => 1, B => 0} , check => 'yes' ) # result A => 1 B => 0 , C and D are undef =head2 load_data Load items as an array or hash ref. Array is forwarded to L , and hash is forwarded to L. Example: $cl->load_data(['A','B']) # cannot use check param here $cl->load_data( data => ['A','B']) $cl->load_data( data => ['A','B'], check => 'yes') $cl->load_data( { A => 1, B => 1 } ) $cl->load_data( data => { A => 1, B => 1 }, check => 'yes') =head2 is_bad_mode Accept a mode parameter. This function checks if the mode is accepted by L method. Returns an error message if not. For instance: if (my $err = $val->is_bad_mode('foo')) { croak "my_function: $err"; } This method is intented as a helper ti avoid duplicating the list of accepted modes for functions that want to wrap fetch methods (like L or L) =head1 Ordered checklist methods All the methods below are valid only for ordered checklists. =head2 swap Parameters: C<< ( choice_a, choice_b) >> Swap the 2 given choice in the list. Both choice must be already set. =head2 move_up Parameters: C<< ( choice ) >> Move the choice up in the checklist. =head2 move_down Parameters: C<< ( choice ) >> Move the choice down in the checklist. =head1 AUTHOR Dominique Dumont, (ddumont at cpan dot org) =head1 SEE ALSO L, L, L, L, L, L, L =head1 AUTHOR Dominique Dumont =head1 COPYRIGHT AND LICENSE This software is Copyright (c) 2005-2022 by Dominique Dumont. This is free software, licensed under: The GNU Lesser General Public License, Version 2.1, February 1999 =cut Config-Model-2.149/lib/Config/Model/Describe.pm0000644000175000017500000002371014170053137017533 0ustar domidomi# # This file is part of Config-Model # # This software is Copyright (c) 2005-2022 by Dominique Dumont. # # This is free software, licensed under: # # The GNU Lesser General Public License, Version 2.1, February 1999 # package Config::Model::Describe 2.149; use Carp; use strict; use warnings; use Config::Model::Exception; use Config::Model::ObjTreeScanner; use List::Util qw/max/; use utf8; sub new { bless {}, shift; } sub describe { my $self = shift; my %args = @_; my $desc_node = delete $args{node} || croak "describe: missing 'node' parameter"; my $check = delete $args{check} || 'yes'; my $element = delete $args{element} ; # optional my $pattern = delete $args{pattern} ; # optional my $hide_empty = delete $args{hide_empty} // 0 ; # optional my $verbose = delete $args{verbose} // 0 ; # optional my $show_empty = ! $hide_empty ; my $tag_name = sub { $_[1] .= ' ⚠' if $_[0]->has_warning; }; my $my_content_cb = sub { my ( $scanner, $data_ref, $node, @element ) = @_; # filter elements according to pattern my @scan = $pattern ? grep { $_ =~ $pattern } @element : @element; for (@scan) { $scanner->scan_element( $data_ref, $node, $_ ) } }; my $std_cb = sub { my ( $scanner, $data_r, $obj, $element, $index, $value_obj ) = @_; my $value = $value_obj->fetch( check => $check, mode => 'user' ); return unless $show_empty or (defined $value and length($value)); $value = substr($value,0,12).'[…]' if $value and length($value) > 12; $value = '"' . $value . '"' if defined $value and $value =~ /\s/; my $name = defined $index ? "$element:$index" : $element; $value = defined $value ? $value : '[undef]'; my $type = $value_obj->value_type; my @comment; if (my $default = $value_obj->fetch(mode => 'standard')) { my $defstr = $type =~ /uniline|string/ ? qq!"$default"! : $default; push @comment, "default: $defstr"; } push @comment, "choice: " . join( ' ', @{ $value_obj->choice } ) if $type eq 'enum'; push @comment, 'mandatory' if $value_obj->mandatory; $tag_name->($value_obj,$element); push @$data_r, [ $name, $type, $value, join( ', ', @comment ) ]; }; my $list_element_cb = sub { my ( $scanner, $data_r, $obj, $element, @keys ) = @_; #print "DEBUG: list_element_cb on $element, keys @keys\n"; my $list_obj = $obj->fetch_element($element); my $elt_type = $list_obj->cargo_type; $tag_name->($list_obj,$element); if ( $elt_type eq 'node' ) { my $class_name = $list_obj->config_class_name; my @show_keys = @keys ? @keys : (''); push @$data_r, [ $element, "<$class_name>", 'node list', "indexes: @show_keys" ]; } else { my @values = grep { $show_empty or length } $list_obj->fetch_all_values( check => 'no' ) ; push @$data_r, [ $element, 'list', join( ',', @values ), '' ] if ($show_empty or @values); } }; my $check_list_element_cb = sub { my ( $scanner, $data_r, $obj, $element, @choices ) = @_; my $list_obj = $obj->fetch_element($element); $tag_name->($list_obj,$element); my @checked = $list_obj->get_checked_list; push @$data_r, [ $element, 'check_list', join( ',', @checked ), '' ] if $show_empty or @checked; }; my $hash_element_cb = sub { my ( $scanner, $data_r, $obj, $element, @keys ) = @_; #print "DEBUG: hash_element_cb on $element, keys @keys\n"; my $hash_obj = $obj->fetch_element($element); my $elt_type = $hash_obj->cargo_type; $tag_name->($hash_obj,$element); if ( $elt_type eq 'node' ) { my $class_name = $hash_obj->config_class_name; my @show_keys = @keys ? map { qq("$_") } @keys : (''); my $show_str = "keys: @show_keys"; push @$data_r, [ $element, 'node hash', "<$class_name>", $show_str ]; } elsif (@keys) { for ( @keys ) { $scanner->scan_hash( $data_r, $obj, $element, $_ ) } } else { push @$data_r, [ $element, 'value hash', "[empty hash]", "" ] if $show_empty; } }; my $node_element_cb = sub { my ( $scanner, $data_r, $obj, $element, $key, $next ) = @_; #print "DEBUG: elt_cb on $element, key $key\n"; my $type = $obj->element_type($element); my $class_name = $next->config_class_name; push @$data_r, [ $element, 'node', "<$class_name>", $obj->gist ]; #$ret .= ":$key" if $type eq 'list' or $type eq 'hash'; #$view_scanner->scan_node($next); }; my @scan_args = ( fallback => 'all', auto_vivify => 0, list_element_cb => $list_element_cb, check_list_element_cb => $check_list_element_cb, hash_element_cb => $hash_element_cb, leaf_cb => $std_cb, node_element_cb => $node_element_cb, node_content_cb => $my_content_cb, ); my @left = keys %args; croak "Describe: unknown parameter:@left" if @left; # perform the scan my $view_scanner = Config::Model::ObjTreeScanner->new(@scan_args); my @ret; if ( defined $element and $desc_node->has_element($element) ) { $view_scanner->scan_element( \@ret, $desc_node, $element ); } elsif ( defined $element ) { Config::Model::Exception::UnknownElement->throw( object => $desc_node, function => 'Describe', where => $desc_node->location || 'configuration root', element => $element, ); } else { $view_scanner->scan_node( \@ret, $desc_node ); } my @header = qw/name type value/; my $name_length = max map { length($_->[0]) } (@ret, \@header ); my $type_length = max map { length($_->[1]) } (@ret, \@header ); my $value_length = max map { length($_->[2]) } (@ret, \@header ); my $sep_length = $name_length + $type_length + $value_length + 4 ; my @format = ("%-${name_length}s", "%-${type_length}s", "%-${value_length}s") ; my @show ; if ($verbose) { push @format, "%-35s"; @show = ( sprintf( join(" │ ", @format)."\n", qw/name type value comment/) , sprintf( join("─┼─", @format)."\n", '─' x $name_length,'─' x $type_length,'─' x $value_length,'─' x 20, ) , map { sprintf( join(" │ ", @format)."\n", @$_ ) } @ret ); } else { @show = ( sprintf( join(" │ ", @format)."\n", qw/name type value/) , sprintf( join("─┼─", @format)."\n", '─' x $name_length,'─' x $type_length,'─' x $value_length ) , map { sprintf( join(" │ ", @format)."\n", @$_[0,1,2] ) } @ret ); } return join ('', @show ); } 1; # ABSTRACT: Provide a description of a node element __END__ =pod =encoding UTF-8 =head1 NAME Config::Model::Describe - Provide a description of a node element =head1 VERSION version 2.149 =head1 SYNOPSIS use Config::Model; # define configuration tree object my $model = Config::Model->new; $model->create_config_class( name => "Foo", element => [ [qw/foo bar/] => { type => 'leaf', value_type => 'string' }, ] ); $model ->create_config_class ( name => "MyClass", element => [ [qw/foo bar/] => { type => 'leaf', value_type => 'string' }, hash_of_nodes => { type => 'hash', # hash id index_type => 'string', cargo => { type => 'node', config_class_name => 'Foo' }, }, ], ) ; my $inst = $model->instance(root_class_name => 'MyClass' ); my $root = $inst->config_root ; # put data my $steps = 'foo=FOO hash_of_nodes:fr foo=bonjour - hash_of_nodes:en foo=hello '; $root->load( steps => $steps ); print $root->describe ; ### prints # name type value comment # foo string FOO # bar string [undef] # hash_of_nodes node hash keys: "en" "fr" =head1 DESCRIPTION This module is used directly by L to describe a node element. This module returns a human readable string that shows the content of a configuration node. For instance (as shown by C example: name type value comment fs_spec string [undef] mandatory fs_vfstype enum [undef] choice: auto davfs ext2 ext3 swap proc iso9660 vfat ignore, mandatory fs_file string [undef] mandatory fs_freq boolean 0 fs_passno integer 0 This module is also used by the C command of L. =head1 CONSTRUCTOR =head2 new No parameter. The constructor should be used only by L. =head1 Methods =head2 describe Return a description string. Parameters are: =over =item node Reference to a L object. Mandatory =item element Describe only this element from the node. Optional. All elements are described if omitted. =item pattern Describe the element matching the regexp ref. Example: describe => ( pattern => qr/^foo/ ) =item hide_empty Boolean. Whether to hide empty value (i.e. C or C<''>) or not. Default is false. =item verbose Boolean. Display more information with each element. Default is false. =back =head1 AUTHOR Dominique Dumont, (ddumont at cpan dot org) =head1 SEE ALSO L,L,L =head1 AUTHOR Dominique Dumont =head1 COPYRIGHT AND LICENSE This software is Copyright (c) 2005-2022 by Dominique Dumont. This is free software, licensed under: The GNU Lesser General Public License, Version 2.1, February 1999 =cut Config-Model-2.149/lib/Config/Model/Loader.pm0000644000175000017500000013357114170053137017230 0ustar domidomi# # This file is part of Config-Model # # This software is Copyright (c) 2005-2022 by Dominique Dumont. # # This is free software, licensed under: # # The GNU Lesser General Public License, Version 2.1, February 1999 # package Config::Model::Loader 2.149; use Carp; use strict; use warnings; use 5.10.1; use Mouse; use Config::Model::Exception; use Log::Log4perl qw(get_logger :levels); use JSON; use Path::Tiny; use YAML::Tiny; my $logger = get_logger("Loader"); my $verbose_logger = get_logger("Verbose.Loader"); ## load stuff, similar to grab, but used to set items in the tree ## starting from this node has start_node => ( is => 'ro', isa => 'Config::Model::Node', weak_ref => 1, required => 1, ); has instance => ( is => 'ro', isa => 'Config::Model::Instance', weak_ref => 1, lazy_build => 1, ); sub _build_instance { return $_[0]->start_node->instance; } my %log_dispatch = ( name => sub { my $loc = $_[0]->location; return $loc ? $_[0]->get_type." '$loc'" : "root node"}, qs => sub { my $s = shift; unquote($s); return "'$s'"}, qa => sub { return '"'.join('", "', @{$_[0]}).'"'}, s => sub { return $_[0] }, # nop leaf => sub { return $_[0]->get_type." '". $_[0]->location."' ".$_[0]->value_type;} ); sub _log_cmd { my ($self, $cmd, $message, @params) = @_; return unless $verbose_logger->is_info; return if $self->instance->initial_load; $cmd =~ s/\n/\\n/g; foreach my $p (@params) { $message =~ s/%(\w+)/$log_dispatch{$1}->($p)/e; } my $str = ref $cmd eq 'ARRAY' ? "@$cmd" : ref $cmd ? $$cmd : $cmd; $verbose_logger->info("command '$str': $message"); } sub load { my $self = shift; my %args = @_; my $node = $self->start_node; my $steps = delete $args{steps} // delete $args{step}; croak "load error: missing 'steps' parameter" unless defined $steps; my $caller_is_root = delete $args{caller_is_root}; if (delete $args{experience}) { carp "load: experience parameter is deprecated"; } my $inst = $node->instance; # tune value checking my $check = delete $args{check} || 'yes'; croak __PACKAGE__, "load: unexpected check $check" unless $check =~ /yes|no|skip/; # accept commands my $huge_string = ref $steps ? join( ' ', @$steps ) : $steps; # 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->trace("_load returned $ret"); # found '!' command if ( $ret eq 'root' ) { $current_node = $caller_is_root ? $node : $current_node->root; if ($logger->debug) { $logger->debug("Setting current_node to root node: ".$current_node->name); } } } while ( $ret eq 'root' ); if (@command) { my $str = "Error: could not execute the required command, "; if ($command[0] =~ m!^/([\w-]+)!) { $str .= "the searched item '$1' was not found" ; } else { $str .= "you may have specified too many '-' in your command"; } Config::Model::Exception::Load->throw( command => $command[0], error => $str, object => $node ) if $check eq 'yes'; } if (%args) { Config::Model::Exception::Internal->throw( error => __PACKAGE__ . " load: unexpected parameters: " . join( ', ', keys %args ) ); } return $ret; } # returns elt action id subaction value sub _split_cmd { my $cmd = shift; $logger->trace("split on: ->$cmd<-"); my $quoted_string = qr/"(?: \\" | [^"] )* "/x; # quoted string # do a split on ' ' but take quoted string into account my @command = ( $cmd =~ m!^ (\w[\w-]*)? # element name can be alone (?: (:~|:-[=~]?|:=~|:\.\w+|:[=<>@]?|~) # action (?: (?: \( ( $quoted_string | [^)]+ ) \) ) # capture parameters between ( ) | ( /[^/]+/ # regexp | (?: $quoted_string (?:,)? | [^#=\.<>]+ # non action chars )+ ) )? )? (?: (=~|\.=|=\.\w+|[=<>]) # apply regexp or assign or append (?: (?: \( ( $quoted_string | [^)]+ ) \) ) # capture parameters between ( ) | ( (?: $quoted_string | [^#\s] # or non whitespace )+ # many ) )? )? (?: \# # optional annotation ( (?: $quoted_string | [^\s] # or non whitespace )+ # many ) )? (.*) # leftover !gx ); my $leftout = pop @command; if ($leftout) { Config::Model::Exception::Load->throw( command => $cmd, error => "Syntax error: spurious char at command end: '$leftout'. Did you forget double quotes ?" ); } return 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->trace("_load: called on node $node_name"); my $inst = $node->instance; my $cmd; while ( $cmd = shift @$cmdref ) { if ( $logger->is_debug ) { my $msg = $cmd; $msg =~ s/\n/\\n/g; $logger->debug("Loader: Executing cmd '$msg' on node $node_name"); } next if $cmd =~ /^\s*$/; if ( $cmd eq '!' ) { $self->_log_cmd(\$cmd,"Going from %name to root node", $node ); $logger->debug("_load: going to root, at_top_level is $at_top_level"); # Do not change current node as we don't want to mess up =~ commands return 'root'; } if ( $cmd eq '-' ) { my $parent = $node->parent; if (defined $parent) { $self->_log_cmd($cmd,'Going up from %name to %name', $node, $node->parent); } else { $self->_log_cmd($cmd,'Going up from %name to exit Loader.', $node); } return 'up'; } if ( $cmd =~ m!^/([\w-]+)! ) { my $search = $1; if ($node->has_element($search)) { $self->_log_cmd($cmd, 'Element %qs found in current node (%name).', $search, $node); $cmd =~ s!^/!! ; } else { $self->_log_cmd( $cmd, 'Going up from %name to %name to search for element %qs.', $node, $node->parent, $search ); unshift @$cmdref, $cmd; return 'up'; } } my ( $element_name, $action, $function_param, $id, $subaction, $value_function_param2, $value_param, $note ) = _split_cmd($cmd); # regexp ensure that only $value_function_param $value_param is set my $value = $value_function_param2 // $value_param ; my @instructions = ( $element_name, $action, $function_param, $id, $subaction, $value, $note ); if ( $logger->is_debug ) { my @disp = map { defined $_ ? "'$_'" : '' } @instructions; $logger->debug("_load instructions: @disp (from: $cmd)"); } if ( not defined $element_name and not defined $note ) { Config::Model::Exception::Load->throw( command => $cmd, error => 'Syntax error: cannot find element in command' ); } unless ( defined $node ) { Config::Model::Exception::Load->throw( command => $cmd, error => "Error: Got undefined node" ); } unless ( $node->isa("Config::Model::Node") or $node->isa("Config::Model::WarpedNode") ) { Config::Model::Exception::Load->throw( command => $cmd, error => "Error: Expected a node (even a warped node), got '" . $node->name . "'" ); # below, has_element method from WarpedNode will raise # exception if warped_node is not available } if ( not defined $element_name and defined $note ) { $self->_set_note($node, \$cmd, $note); next; } unless ( $node->has_element($element_name) ) { Config::Model::Exception::UnknownElement->throw( object => $node, element => $element_name, ) if $check eq 'yes'; unshift @$cmdref, $cmd; return 'error'; } unless ( $node->is_element_available( name => $element_name ) ) { Config::Model::Exception::UnavailableElement->throw( object => $node, element => $element_name ) if $check eq 'yes'; unshift @$cmdref, $cmd; return 'error'; } unless ( $node->is_element_available( name => $element_name ) ) { Config::Model::Exception::RestrictedElement->throw( object => $node, element => $element_name, ) if $check eq 'yes'; unshift @$cmdref, $cmd; return 'error'; } my $element_type = $node->element_type($element_name); my $method = $load_dispatch{$element_type}; croak "_load: unexpected element type '$element_type' for $element_name" unless defined $method; $logger->debug("_load: calling $element_type loader on element $element_name"); my $ret = $self->$method( $node, $check, \@instructions, $cmdref, $cmd ); $logger->debug("_load: $element_type loader on element $element_name returned $ret"); die "Internal error: method dispatched for $element_type returned an undefined value " unless defined $ret; if ( $ret eq 'error' or $ret eq 'done' ) { $logger->debug("_load return: $node_name got $ret"); return $ret; } if ( $ret eq 'root' and not $at_top_level ) { $logger->debug("_load return: $node_name got $ret"); return 'root'; } # ret eq up or ok -> go on with the loop } return 'done'; } sub _set_note { my ($self, $target, $cmd, $note) = @_; $self->_log_cmd($cmd, "Setting %name annotation to %qs", $target, $note); $target->annotation($note); } sub _load_note { my ( $self, $target_obj, $note, $instructions, $cmdref, $cmd ) = @_; unquote($note); # apply note on target object if ( defined $note ) { if ( defined $target_obj ) { $self->_set_note($target_obj, $cmd,$note); } else { Config::Model::Exception::Load->throw( command => $$cmdref, error => "Error: cannot set annotation with '" . join( "','", grep { defined $_ } @$instructions ) . "'" ); } } } sub _walk_node { my ( $self, $node, $check, $inst, $cmdref, $cmd ) = @_; my $element_name = shift @$inst; my $note = pop @$inst; my $new_node = $node->fetch_element($element_name); $self->_load_note( $new_node, $note, $inst, $cmdref, $cmd ); my @left = grep { defined $_ } @$inst; if (@left) { Config::Model::Exception::Load->throw( command => $inst, object => $node, error => "Don't know what to do with '@left' " . "for node element $element_name" ); } $self->_log_cmd($cmd, 'Going down from %name to %name', $node, $new_node); return $self->_load( $new_node, $check, $cmdref ); } sub unquote { for (@_) { if (defined $_) { s/(?fetch_element( name => $element_name, check => $check ); if ( defined $note and not defined $action and not defined $subaction ) { $self->_load_note( $element, $note, $inst, $cmdref, $cmd ); return 'ok'; } if ( defined $subaction and $subaction eq '=' ) { $logger->debug("_load_check_list: set whole list"); $self->_log_cmd($cmd, 'Setting %name items %qs.', $element, $value); # valid for check_list or list $element->load( $value, check => $check ); $self->_load_note( $element, $note, $inst, $cmdref, $cmd ); return 'ok'; } if ( not defined $action and defined $subaction ) { Config::Model::Exception::Load->throw( object => $element, command => join( '', grep { defined $_} @$inst ), error => "Wrong assignment with '$subaction' on check_list" ); } my $a_str = defined $action ? $action : ''; Config::Model::Exception::Load->throw( object => $element, command => join( '', map { $_ || '' } @$inst ), error => "Wrong assignment with '$a_str' on check_list" ); } { # sub is called with ( $self, $element, $check, $instance, @function_args ) # function_args are the arguments passed to the load command my %dispatch_action = ( list_leaf => { ':.sort' => sub { $_[1]->sort; return 'ok';}, ':.push' => sub { $_[1]->push( @_[ 5 .. $#_ ] ); return 'ok'; }, ':.unshift' => sub { $_[1]->unshift( @_[ 5 .. $#_ ] ); return 'ok'; }, ':.insert_at' => sub { $_[1]->insert_at( @_[ 5 .. $#_ ] ); return 'ok'; }, ':.insort' => sub { $_[1]->insort( @_[ 5 .. $#_ ] ); return 'ok'; }, ':.insert_before' => \&_insert_before, }, 'list_*' => { ':.copy' => sub { $_[1]->copy( $_[5], $_[6] ); return 'ok'; }, ':.clear' => sub { $_[1]->clear; return 'ok'; }, }, hash_leaf => { ':.insort' => sub { $_[1]->insort($_[5])->store($_[6]); return 'ok'; }, }, hash_node => => { ':.insort' => \&_insort_hash_of_node, }, 'hash_*' => { ':.sort' => sub { $_[1]->sort; return 'ok'; }, ':.copy' => sub { $_[1]->copy( $_[5], $_[6] ); return 'ok'; }, ':.clear' => sub { $_[1]->clear; return 'ok';}, }, # part of list or hash. leaf element have their own dispatch table # (%load_value_dispatch) because the signture of the sub ref are # different between the 2 dispatch tables. leaf => { ':.rm_value' => \&_remove_by_value, ':.rm_match' => \&_remove_matched_value, ':.substitute' => \&_substitute_value, }, fallback => { ':.rm' => \&_remove_by_id, ':.json' => \&_load_json_vector_data, } ); my %equiv = ( 'hash_*' => { qw/:@ :.sort/}, list_leaf => { qw/:@ :.sort :< :.push :> :.unshift/ }, # fix for cme gh#2 leaf => { qw/:-= :.rm_value :-~ :.rm_match :=~ :.substitute/ }, fallback => { qw/:- :.rm ~ :.rm/ }, ); while ( my ($target, $sub_equiv) = each %equiv) { while ( my ($new_action, $existing_action) = each %$sub_equiv) { $dispatch_action{$target}{$new_action} = $dispatch_action{$target}{$existing_action}; } } sub _get_dispatch_data { my ($dispatch, $type, $cargo_type, $action) = @_; return $dispatch->{ $type.'_'.$cargo_type }{$action} || $dispatch->{$type.'_*'}{$action} || $dispatch->{$cargo_type}{$action} || $dispatch->{'fallback'}{$action}; } sub _get_dispatch { my ($self, $element, $type, $cargo_type, $action, $cmd, @f_args, ) = @_; return unless (defined $action and $action ne ':'); my $dispatch = _get_dispatch_data(\%dispatch_action, $type => $cargo_type, $action); if ($dispatch) { my $real_action = _get_dispatch_data(\%equiv, $type => $cargo_type, $action) // $action; $self->_log_cmd($cmd, 'Running %qs on %name with %qa.', substr($real_action,2), $element, \@f_args); } return $dispatch; } } sub _insert_before { my ( $self, $element, $check, $inst, $cmdref, $before_str, @values ) = @_; my $before = ($before_str =~ s!^/!! and $before_str =~ s!/$!!) ? qr/$before_str/ : $before_str; $element->insert_before( $before, @values ); return 'ok'; } sub _remove_by_id { my ( $self, $element, $check, $inst, $cmdref, $id ) = @_; $logger->debug("_remove_by_id: removing id '$id'"); $element->remove($id); return 'ok'; } sub _load_json_vector_data { my ( $self, $element, $check, $inst, $cmdref, $vector ) = @_; $logger->debug("_load_json_vector_data: loading '$vector'"); my ($file, @vector) = $self->__get_file_from_vector($element,$inst,$vector); my $data = decode_json($file->slurp_utf8); # test for diff before clobbering ? What about deep data ??? $element->load_data( data => __data_from_vector($data, @vector), check => $check ); return 'ok'; } sub _remove_by_value { my ( $self, $element, $check, $inst, $cmdref, $rm_val ) = @_; $logger->debug("_remove_by_value value $rm_val"); foreach my $idx ( $element->fetch_all_indexes ) { my $v = $element->fetch_with_id($idx)->fetch; $element->delete($idx) if defined $v and $v eq $rm_val; } return 'ok'; } sub _remove_matched_value { my ( $self, $element, $check, $inst, $cmdref, $rm_val ) = @_; $logger->debug("_remove_matched_value $rm_val"); $rm_val =~ s!^/|/$!!g; foreach my $idx ( $element->fetch_all_indexes ) { my $v = $element->fetch_with_id($idx)->fetch; $element->delete($idx) if defined $v and $v =~ /$rm_val/; } return 'ok'; } sub _substitute_value { my ( $self, $element, $check, $inst, $cmdref, $s_val ) = @_; $logger->debug("_substitute_value $s_val"); foreach my $idx ( $element->fetch_all_indexes ) { my $l = $element->fetch_with_id($idx); $self->_load_value( $l, $check, '=~', $s_val, $inst ); } return 'ok'; } sub _insort_hash_of_node { my ( $self, $element, $check, $inst, $cmdref, $id ) = @_; my $node = $element->insort($_[5]); $logger->debug("_insort_hash_of_node: calling _load on node id $id"); return $self->_load( $node, $check, $cmdref ); } sub _load_list { my ( $self, $node, $check, $inst, $cmdref, $cmd ) = @_; my ( $element_name, $action, $f_arg, $id, $subaction, $value, $note ) = @$inst; my $element = $node->fetch_element( name => $element_name, check => $check ); my @f_args = grep { defined } ( ( $f_arg // $id // '' ) =~ /([^,"]+)|"([^"]+)"/g ); my $elt_type = $node->element_type($element_name); my $cargo_type = $element->cargo_type; if ( defined $note and not defined $action and not defined $subaction ) { $self->_load_note( $element, $note, $inst, $cmdref, $cmd ); return 'ok'; } if ( defined $action and $action eq ':=' and $cargo_type eq 'leaf' ) { # due to ':=' action, the value is contained in $id $logger->debug("_load_list: set whole list with ':=' action"); # valid for check_list or list $self->_log_cmd($cmd, 'Setting %name values to %qs.', $element, $id); $element->load( $id, check => $check ); $self->_load_note( $element, $note, $inst, $cmdref, $cmd ); return 'ok'; } # compat mode for list=a,b,c,d commands if ( not defined $action and defined $subaction and $subaction eq '=' and $cargo_type eq 'leaf' ) { $logger->debug("_load_list: set whole list with '=' subaction'"); # valid for check_list or list $self->_log_cmd($cmd, 'Setting %name values to %qs.', $element, $value); $element->load( $value, check => $check ); $self->_load_note( $element, $note, $inst, $cmdref, $cmd ); return 'ok'; } unquote( $id, $value, $note ); if ( my $dispatch = $self->_get_dispatch($element, list => $cargo_type, $action, $cmd, @f_args)) { return $dispatch->( $self, $element, $check, $inst, $cmdref, @f_args ); } if ( not defined $action and defined $subaction ) { Config::Model::Exception::Load->throw( object => $element, command => join( '', grep { defined $_} @$inst ), error => "Wrong assignment with '$subaction' on " . "element type: $elt_type, cargo_type: $cargo_type" ); } if ( defined $action and $action eq ':' ) { unquote($id); my $obj = $element->fetch_with_id( index => $id, check => $check ); $self->_load_note( $obj, $note, $inst, $cmdref, $cmd ); if ( $cargo_type =~ /node/ ) { # remove possible leading or trailing quote $self->_log_cmd($cmd,'Going down from %name to %name', $node, $obj ); return $self->_load( $obj, $check, $cmdref ); } return 'ok' unless defined $subaction; if ( $cargo_type =~ /leaf/ ) { $logger->debug("_load_list: calling _load_value on $cargo_type id $id"); # _log_cmd done in _load_value $self->_load_value( $obj, $check, $subaction, $value, $cmdref, $cmd ) and return 'ok'; } } my $a_str = defined $action ? $action : ''; Config::Model::Exception::Load->throw( object => $element, command => join( '', map { $_ || '' } @$inst ), error => "Wrong assignment with '$a_str' on " . "element type: $elt_type, cargo_type: $cargo_type" ); } sub _load_hash { my ( $self, $node, $check, $inst, $cmdref, $cmd ) = @_; my ( $element_name, $action, $f_arg, $id, $subaction, $value, $note ) = @$inst; unquote( $id, $value, $note ); my $element = $node->fetch_element( name => $element_name, check => $check ); my $cargo_type = $element->cargo_type; if ( defined $note and not defined $action ) { # _log_cmd done in _load_note $self->_load_note( $element, $note, $inst, $cmdref, $cmd ); return 'ok'; } if ( not defined $action ) { Config::Model::Exception::Load->throw( object => $element, command => join( '', map { $_ || '' } @$inst ), error => "Missing key (e.g. '$element_name:some_key') on hash element, cargo_type: $cargo_type" ); } # loop requires $subaction so does not fit in the dispatch table if ( $action eq ':~' or $action eq ':.foreach_match' ) { my @keys = $element->fetch_all_indexes; my $ret = 'ok'; my $pattern = $id // $f_arg; $pattern =~ s!^/|/$!!g if $pattern; my @loop_on = $pattern ? grep { /$pattern/ } @keys : @keys; if ($logger->is_debug) { my $str = $pattern ? " with regex /$pattern/" : ''; $logger->debug("_load_hash: looping$str on keys @loop_on"); } my @saved_cmd = @$cmdref; foreach my $loop_id ( @loop_on ) { @$cmdref = @saved_cmd; # restore command before loop my $sub_elt = $element->fetch_with_id($loop_id); $self->_log_cmd($cmd,'Running foreach_map loop on %name.',$sub_elt); if ( $cargo_type =~ /node/ ) { # remove possible leading or trailing quote $ret = $self->_load( $sub_elt, $check, $cmdref ); } elsif ( $cargo_type =~ /leaf/ ) { $ret = $self->_load_value( $sub_elt, $check, $subaction, $value, $cmdref, $cmd ); } else { Config::Model::Exception::Load->throw( object => $element, command => join( '', @$inst ), error => "Hash assignment with '$action' on unexpected " . "cargo_type: $cargo_type" ); } $logger->debug("_load_hash: loop on id $loop_id returned $ret (left cmd: @$cmdref)"); if ( $ret eq 'error') { return $ret; } } return $ret; } my @f_args = grep { defined } ( ( $f_arg // $id // '' ) =~ /([^,"]+)|"([^"]+)"/g ); if ( my $dispatch = $self->_get_dispatch($element, hash => $cargo_type, $action, $cmd, @f_args)) { return $dispatch->( $self, $element, $check, $inst, $cmdref, @f_args ); } if (not defined $id) { Config::Model::Exception::Load->throw( object => $element, command => join( '', @$inst ), error => qq!Unexpected hash instruction: '$action' or missing id! ); } my $obj = $element->fetch_with_id( index => $id, check => $check ); $self->_load_note( $obj, $note, $inst, $cmdref, $cmd ); if ( $action eq ':' and $cargo_type =~ /node/ ) { # remove possible leading or trailing quote $self->_log_cmd($cmd,'Going down from %name to %name', $node, $obj ); if ( defined $subaction ) { Config::Model::Exception::Load->throw( object => $element, command => join( '', @$inst ), error => qq!Hash assignment with '$action"$id"$subaction"$value"' on unexpected ! . "cargo_type: $cargo_type" ); } return $self->_load( $obj, $check, $cmdref ); } elsif ( $action eq ':' and defined $subaction and $cargo_type =~ /leaf/ ) { # _log_cmd is done in _load_value $logger->debug("_load_hash: calling _load_value on leaf $id"); $self->_load_value( $obj, $check, $subaction, $value, $cmdref, $cmd ) and return 'ok'; } elsif ( $action eq ':' ) { $self->_log_cmd($cmd,'Creating empty %name.', $obj ); $logger->debug("_load_hash: created empty element of type $cargo_type"); return 'ok'; } elsif ($action) { $logger->debug("_load_hash: giving up"); Config::Model::Exception::Load->throw( object => $element, command => join( '', grep { defined $_ } @$inst ), error => "Hash load with '$action' on unexpected " . "cargo_type: $cargo_type" ); } } sub _load_leaf { my ( $self, $node, $check, $inst, $cmdref, $cmd ) = @_; my ( $element_name, $action, $f_arg, $id, $subaction, $value, $note ) = @$inst; unquote( $id, $value ); my $element = $node->fetch_element( name => $element_name, check => $check ); $self->_load_note( $element, $note, $inst, $cmdref, $cmd ); if ( defined $action and $element->isa('Config::Model::Value')) { if ($action eq '~') { $self->_log_cmd($cmd, "Deleting %name.", $element ); $element->store(value => undef, check => $check); } elsif ($action eq ':') { Config::Model::Exception::Load->throw( object => $element, command => $inst, error => "Error: list or hash command (':') detected on a leaf." . "(element '" . $element->name . "')" ); } else { Config::Model::Exception::Load->throw( object => $element, command => $inst, error => "Load error on leaf with " . "'$element_name$action$id' command " . "(element '" . $element->name . "')" ); } } return 'ok' unless defined $subaction; if ( $logger->is_debug ) { my $msg = defined $value ? $value : ''; $msg =~ s/\n/\\n/g; $logger->debug("_load_leaf: action '$subaction' value '$msg'"); } my $res = $self->_load_value( $element, $check, $subaction, $value, $inst, $cmd ); return $res if $res ; Config::Model::Exception::Load->throw( object => $element, command => $inst, error => "Load error on leaf with " . "'$element_name$subaction$value' command " . "(element '" . $element->name . "')" ); } # sub is called with ( $self, $element, $value, $check, $instructions ) # function_args are the arguments passed to the load command my %load_value_dispatch = ( '=' => \&_store_value , '.=' => \&_append_value, '=~' => \&_apply_regexp_on_value, '=.file' => \&_store_file_in_value, '=.json' => \&_store_json_vector_in_value, '=.yaml' => \&_store_yaml_vector_in_value, '=.env' => sub { $_[1]->store( value => $ENV{$_[2]}, check => $_[3] ); return 'ok'; }, ); sub _store_value { my ( $self, $element, $value, $check, $instructions, $cmd ) = @_; $self->_log_cmd($cmd, 'Setting %leaf to %qs.', $element, $value); $element->store( value => $value, check => $check ); return 'ok'; } sub _append_value { my ( $self, $element, $value, $check, $instructions, $cmd ) = @_; my $orig = $element->fetch( check => $check ); my $next = $orig.$value; $self->_log_cmd( $cmd, 'Appending %qs to %leaf. Result is %qs.', $value, $element, $next ); $element->store( value => $next, check => $check ); } sub _apply_regexp_on_value { my ( $self, $element, $value, $check, $instructions, $cmd ) = @_; my $orig = $element->fetch( check => $check ); if (defined $orig) { # $value may change at each run and is like s/foo/bar/ do block # eval is not possible eval("\$orig =~ $value;"); ## no critic (ProhibitStringyEval) my $res = $@; $self->_log_cmd( $cmd, "Applying regexp %qs to %leaf. Result is %qs.", $value, $element, $orig ); if ($res) { Config::Model::Exception::Load->throw( object => $element, command => $instructions, error => "Failed regexp '$value' on " . "element '" . $element->name . "' : $res" ); } $element->store( value => $orig, check => $check ); } else { $self->_log_cmd( $cmd, "Not applying regexp %qs on undefined value of %leaf.", $value, $element, $orig ); } } sub _store_file_in_value { my ( $self, $element, $value, $check, $instructions, $cmd ) = @_; if ($value eq '-') { $element->store( value => join('',), check => $check ); return 'ok'; } my $path = $element->root_path->child($value); if ($path->is_file) { $element->store( value => $path->slurp_utf8, check => $check ); } else { Config::Model::Exception::Load->throw( object => $element, command => $instructions, error => "cannot read file $value" ); } } sub __data_from_vector { my ($data, @vector) = @_; for my $step (@vector) { $data = (ref($data) eq 'HASH') ? $data->{$step} : $data->[$step]; } return $data; } sub __get_file_from_vector { my ($self, $element,$instructions,$raw_vector) = @_; my @vector = split m![/]+!m, $raw_vector; my $cur = path('.'); my $file; while (my $subpath = shift @vector) { my $new_path = $cur->child($subpath); if ($new_path->is_file) { $file = $new_path; last; } elsif ($new_path->is_dir) { $cur = $new_path; } } if (not defined $file) { my ( $element_name, $action, $f_arg, $id, $subaction, $value, $note ) = @$instructions; Config::Model::Exception::Load->throw( object => $element, command => "$element_name" . ( $action ? "$action($f_arg)" : '' ) . ( $subaction ? "$subaction($value)" : '' ), error => qq!Load error: Cannot find file in $value! ); } return ($file, @vector); } sub _store_json_vector_in_value { my ( $self, $element, $value, $check, $instructions, $cmd ) = @_; my ($file, @vector) = $self->__get_file_from_vector($element,$instructions,$value); my $data = decode_json($file->slurp_utf8); $element->store( value => __data_from_vector($data, @vector), check => $check ); } sub _store_yaml_vector_in_value { my ( $self, $element, $value, $check, $instructions, $cmd ) = @_; my ($file, @vector) = $self->__get_file_from_vector($element,$instructions,$value); my $data = YAML::Tiny->read($file->stringify); $element->store( value => __data_from_vector($data, @vector), check => $check ); } sub _load_value { my ( $self, $element, $check, $subaction, $value, $instructions, $cmd ) = @_; if (not $element->isa('Config::Model::Value')) { my $class = ref($element); Config::Model::Exception::Load->throw( object => $element, command => $instructions, error => "Load error: _load_value called on non Value object. ($class)" ); } $logger->debug("_load_value: action '$subaction' value '$value' check $check"); my $dispatch = $load_value_dispatch{$subaction}; if ($dispatch) { return $dispatch->( $self, $element, $value, $check, $instructions, $cmd ); } else { Config::Model::Exception::Load->throw( object => $element, command => $instructions, error => "Unexpected operator or function on value: $subaction" ); } $logger->debug("_load_value: done returns ok"); return 'ok'; } 1; # ABSTRACT: Load serialized data into config tree __END__ =pod =encoding UTF-8 =head1 NAME Config::Model::Loader - Load serialized data into config tree =head1 VERSION version 2.149 =head1 SYNOPSIS use Config::Model; # define configuration tree object my $model = Config::Model->new; $model->create_config_class( name => "Foo", element => [ [qw/foo bar/] => { type => 'leaf', value_type => 'string' }, ] ); $model ->create_config_class ( name => "MyClass", element => [ [qw/foo bar/] => { type => 'leaf', value_type => 'string' }, hash_of_nodes => { type => 'hash', # hash id index_type => 'string', cargo => { type => 'node', config_class_name => 'Foo' }, }, [qw/lista listb/] => { type => 'list', cargo => {type => 'leaf', value_type => 'string' } }, ], ) ; my $inst = $model->instance(root_class_name => 'MyClass' ); my $root = $inst->config_root ; # put data my $steps = 'foo=FOO hash_of_nodes:fr foo=bonjour - hash_of_nodes:en foo=hello ! lista=foo,bar lista:2=baz listb:0=foo listb:1=baz'; $root->load( steps => $steps ); 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( steps => 'lista~2' ); print $root->describe(element => 'lista'),"\n" ; # name value type comment # lista foo,bar list # append some data $root->load( steps => 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 The constructor should be used only by L. Parameters: =over =item start_node node ref of the root of the tree (of sub-root) to start the load from. Stored as a weak reference. =back =head1 load string syntax The string is made of the following items (also called C) separated by spaces. These actions can be divided in 4 groups: =over =item * navigation: moving up and down the configuration tree. =item * list and hash operation: select, add or delete hash or list item (also known as C items) =item * leaf operation: select, modify or delecte leaf value =item * annotation: modify or delete configuration annotation (aka comment) =back =head2 navigation =over 8 =item - Go up one node =item ! Go to the root node of the configuration tree. =item xxx Go down using C element. (For C type element) =item /xxx Go up until the element C is found. This search can be combined with one of the command specified below, e.g C =back =head2 list and hash operation =over =item xxx:yy Go down using C element and id C (For C or C element with C cargo_type). Literal C<\n> are replaced by real C<\n> (LF in Unix). =item xxx:.foreach_match(yy) or xxx:~yy Go down using C element and loop over the ids that match the regex specified by C. (For C). For instance, with C model, you could do Host:~"/.*.debian.org/" user='foo-guest' to set "foo-user" users for all your debian accounts. The leading and trailing '/' may be omitted. Be sure to surround the regexp with double quote if space are embedded in the regex. Note that the loop ends when the load command goes above the element where the loop is executed. For instance, the instruction below tries to execute C and C for all elements of C hash: std_id:~/^\w+$/ DX=Bv int_v=9 In the examples below only C is executed by the loop: std_id:~/^\w+$/ DX=Bv - int_v=9 std_id:~/^\w+$/ DX=Bv ! int_v=9 The loop is done on all elements of the hash when no value is passed after "C<:~>" (mnemonic: an empty regexp matches any value). =item xxx:.rm(yy) or xxx:-yy Delete item referenced by C element and id C. For a list, this is equivalent to C. This command does not go down in the tree (since it has just deleted the element). I.e. a 'C<->' is generally not needed afterwards. =item xxx:.rm_value(yy) or xxx:-=yy Remove the element whose value is C. For list or hash of leaves. Does not not complain if the value to delete is not found. =item xxx:..rm_match(yy) or xxx:-~/yy/ Remove the element whose value matches C. For list or hash of leaves. Does not not complain if no value were deleted. =item xxx:.substitute(/yy/zz/) or xxx:=~s/yy/zz/ Substitute a value with another. Perl switches can be used(e.g. C) =item xxx: value on C list =item xxx:>yy or xxx:.unshift(yy) Unshift C value on C list =item xxx:@ or xxx:.sort Sort the list =item xxx:.insert_at(yy,zz) Insert C value on C list before B C. =item xxx:.insert_before(yy,zz) Insert C value on C list before B C. =item xxx:.insert_before(/yy/,zz) Insert C value on C list before B matching C. =item xxx:.insort(zz) Insert C value on C list so that existing alphanumeric order is preserved. =item xxx:.insort(zz) For hash element containing nodes: creates a new hash element with C key on C hash so that existing alphanumeric order of keys is preserved. Note that all keys are sorted once this instruction is called. Following instructions are applied on the created element. I.e. putting key order aside, C has the same effect as C instruction. =item xxx:.insort(zz,vv) For hash element containing leaves: creates a new hash element with C key and assing value C so that existing alphanumeric order of keys is preserved. Note that all keys are sorted once this instruction is called. Putting key order aside, C has the same effect as C instruction. =item xxx:=z1,z2,z3 Set list element C to list C. Use C<,,> for undef values, and C<""> for empty values. I.e, for a list C<('a',undef,'','c')>, use C. =item xxx:yy=zz For C element containing C cargo_type. Set the leaf identified by key C to value C. Using C is also possible. =item xxx:.copy(yy,zz) copy item C in C (hash or list). =item xxx:.json("path/to/file.json/foo/bar") Store C content in array or hash. This should be used to store hash or list of values. You may store deep data structure. In this case, make sure that the structure of the loaded data matches the structure of the model. This won't happen by chance. =item xxx:.clear Clear the hash or list. =back =head2 leaf operation =over =item xxx=zz Set element C to value C. load also accepts to set elements with a quoted string. (For C element) Literal C<\n> are replaced by real C<\n> (LF in Unix). Literal C<\\> are replaced by C<\>. For instance C or C. =item xxx=~s/foo/bar/ Apply the substitution to the value of xxx. C is the standard Perl C substitution pattern. Patterns with white spaces must be surrounded by quotes: xxx=~"s/foo bar/bar baz/" Perl pattern modifiers are accepted xxx=~s/FOO/bar/i =item xxx~ Undef element C =item xxx.=zzz Appends C value to current value (valid for C elements). =item xxx=.file(yyy) Store the content of file C in element C. Store STDIn in value xxx when C is '-'. =item xxx=.json(path/to/data.json/foo/bar) Open file C and store value from JSON data extracted with C subpath. For instance, if C contains: { "foo": { "bar": 42 } } The instruction C stores C<42> in C element. =item xxx=.yaml(path/to/data.yaml/0/foo/bar) Open file C and store value from YAML data extracted with C<0/foo/bar> subpath. Since a YAML file can contain several documents (separated by C<---> lines, the subpath must begin with a number to select the document containing the required value. For instance, if C contains: --- foo: bar: 42 The instruction C stores C<42> in C element. =item xxx=.env(yyy) Store the content of environment variable C in element C. =back =head2 annotation =over =item xxx#zzz or xxx:yyy#zzz Element annotation. Can be quoted or not quoted. Note that annotations are always placed at the end of an action item. I.e. C, C or C are valid. C is B valid. =back =head2 Quotes You can surround indexes and values with 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 steps (or step) A string or an array ref containing the steps to load. See L for a description of the string. =item check Whether to check values while loading. Either C (default), C or C. Bad values are discarded when C is set to C. =item caller_is_root Change the target of the C command: when set, the C command go to caller node instead of going to root node. (default is false) =back =head1 AUTHOR Dominique Dumont, (ddumont at cpan dot org) =head1 SEE ALSO L,L,L =head1 AUTHOR Dominique Dumont =head1 COPYRIGHT AND LICENSE This software is Copyright (c) 2005-2022 by Dominique Dumont. This is free software, licensed under: The GNU Lesser General Public License, Version 2.1, February 1999 =cut Config-Model-2.149/lib/Config/Model/Backend/0000755000175000017500000000000014170053137017001 5ustar domidomiConfig-Model-2.149/lib/Config/Model/Backend/Fstab.pm0000644000175000017500000001400714170053137020400 0ustar domidomi# # This file is part of Config-Model # # This software is Copyright (c) 2005-2022 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 2.149; use Mouse; use Carp; use Log::Log4perl qw(get_logger :levels); extends 'Config::Model::Backend::Any'; my $logger = get_logger("Backend::Fstab"); sub annotation { return 1; } my %opt_r_translate = ( ro => 'rw=0', rw => 'rw=1', bsddf => 'statfs_behavior=bsddf', minixdf => 'statfs_behavior=minixdf', ); sub read { my $self = shift; my %args = @_; # args are: # root => './my_test', # fake root directory, userd for tests # config_dir => /etc/foo', # absolute path # file => 'foo.conf', # file name # file_path => './my_test/etc/foo/foo.conf' # check => yes|no|skip return 0 unless $args{file_path}->exists; # no file to read my $check = $args{check} || 'yes'; my @lines = $args{file_path}->lines_utf8; # try to get global comments (comments before a blank line) $self->read_global_comments( \@lines, '#' ); my @assoc = $self->associates_comments_with_data( \@lines, '#' ); foreach my $item (@assoc) { my ( $data, $comment ) = @$item; $logger->trace("fstab read data '$data' comment '$comment'"); my ( $device, $mount_point, $type, $options, $dump, $pass ) = split /\s+/, $data; my $swap_idx = 0; my $label = $device =~ /LABEL=(\w+)$/ ? $1 : $type eq 'swap' ? "swap-" . $swap_idx++ : $mount_point; my $fs_obj = $self->node->fetch_element('fs')->fetch_with_id($label); if ($comment) { $logger->trace("Annotation: $comment\n"); $fs_obj->annotation($comment); } my $load_line = "fs_vfstype=$type fs_spec=$device fs_file=$mount_point " . "fs_freq=$dump fs_passno=$pass"; $logger->debug("Loading:$load_line\n"); $fs_obj->load( step => $load_line, check => $check ); # now load fs options $logger->trace("fs_type $type options is $options"); my @options; foreach ( split /,/, $options ) { my $o = $opt_r_translate{$_} // $_; $o =~ s/no(.*)/$1=0/; $o .= '=1' unless $o =~ /=/; push @options, $o; } $logger->debug("Loading:@options"); $fs_obj->fetch_element('fs_mntopts')->load( step => "@options", check => $check ); } return 1; } sub write { my $self = shift; my %args = @_; # args are: # object => $obj, # Config::Model::Node object # root => './my_test', # fake root directory, userd for tests # config_dir => /etc/foo', # absolute path # file => 'foo.conf', # file name # file_path => './my_test/etc/foo/foo.conf' # check => yes|no|skip my $node = $args{object}; croak "Undefined file handle to write" unless defined $args{file_path}; my $res = $self->write_global_comment( '#' ); # Using Config::Model::ObjTreeScanner would be overkill foreach my $line_obj ( $node->fetch_element('fs')->fetch_all ) { my $d = sprintf( "%-30s %-25s %-6s %-10s %d %d\n", (map { $line_obj->fetch_element_value($_); } qw/fs_spec fs_file fs_vfstype/), $self->option_string( $line_obj->fetch_element('fs_mntopts') ), (map { $line_obj->fetch_element_value($_); } qw/fs_freq fs_passno/), ); $res .= $self->write_data_and_comments( '#', $d, $line_obj->annotation ); } $args{file_path}->spew_utf8($res); return 1; } my %rev_opt_r_translate = reverse %opt_r_translate; sub option_string { my ( $self, $obj ) = @_; my @options; foreach my $opt ( $obj->get_element_name ) { my $v = $obj->fetch_element_value($opt); next unless defined $v; my $key = "$opt=$v"; my $str = defined $rev_opt_r_translate{$key} ? $rev_opt_r_translate{$key} : "$v" eq '0' ? 'no' . $opt : "$v" eq '1' ? $opt : $key; push @options, $str; } return join ',', @options; } no Mouse; __PACKAGE__->meta->make_immutable; 1; # ABSTRACT: Read and write config from fstab file __END__ =pod =encoding UTF-8 =head1 NAME Config::Model::Backend::Fstab - Read and write config from fstab file =head1 VERSION version 2.149 =head1 SYNOPSIS No synopsis. This class is dedicated to configuration class C =head1 DESCRIPTION This module is used directly by L to read or write the content of a configuration tree written with C syntax in C configuration tree. Typically this backend is used to read and write C. =head1 Comments in file_path This backend is able to read and write comments in the C file. =head1 STOP The documentation below describes methods that are currently used only by L. You don't need to read it to write a model. =head1 CONSTRUCTOR =head2 new Parameters: C<< ( node => $node_obj, name => 'fstab' ) >> Inherited from L. The constructor is called by L. =head2 read Of all parameters passed to this read call-back, only C is used. This parameter must be a L object. When a file is read, C returns 1. =head2 write Of all parameters passed to this write call-back, only C is used. C returns 1. =head1 AUTHOR Dominique Dumont, (ddumont at cpan dot org) =head1 SEE ALSO L, L, L, =head1 AUTHOR Dominique Dumont =head1 COPYRIGHT AND LICENSE This software is Copyright (c) 2005-2022 by Dominique Dumont. This is free software, licensed under: The GNU Lesser General Public License, Version 2.1, February 1999 =cut Config-Model-2.149/lib/Config/Model/Backend/Json.pm0000644000175000017500000001055614170053137020257 0ustar domidomi# # This file is part of Config-Model # # This software is Copyright (c) 2005-2022 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 2.149; use Carp; use strict; use warnings; use Config::Model::Exception; use File::Path; use Log::Log4perl qw(get_logger :levels); use base qw/Config::Model::Backend::Any/; use JSON; my $logger = get_logger("Backend::Json"); sub read { my $self = shift; my %args = @_; # args is: # object => $obj, # Config::Model::Node object # root => './my_test', # fake root directory, userd for tests # config_dir => /etc/foo', # absolute path # file => 'foo.conf', # file name # file_path => './my_test/etc/foo/foo.conf' # check => yes|no|skip return 0 unless defined $args{file_path}->exists; # no file to read # load Json file my $json = $args{file_path}->slurp_utf8; # convert to perl data my $perl_data = decode_json $json ; if ( not defined $perl_data ) { $logger->warn("No data found in Json file $args{file_path}"); return 1; } # load perl data in tree $self->{node}->load_data( data => $perl_data, check => $args{check} || 'yes' ); return 1; } sub write { my $self = shift; my %args = @_; # args is: # object => $obj, # Config::Model::Node object # root => './my_test', # fake root directory, userd for tests # config_dir => /etc/foo', # absolute path # file => 'foo.conf', # file name # file_path => './my_test/etc/foo/foo.conf' # check => yes|no|skip my $perl_data = $self->{node}->dump_as_data( full_dump => $args{full_dump} ); my $json = to_json( $perl_data, { pretty => 1 } ); $args{file_path}->spew_utf8($json); return 1; } 1; # ABSTRACT: Read and write config as a JSON data structure __END__ =pod =encoding UTF-8 =head1 NAME Config::Model::Backend::Json - Read and write config as a JSON data structure =head1 VERSION version 2.149 =head1 SYNOPSIS use Config::Model ; use Data::Dumper ; # define configuration tree object my $model = Config::Model->new ; $model ->create_config_class ( name => "MyClass", element => [ [qw/foo bar/] => { type => 'leaf', value_type => 'string' }, baz => { type => 'hash', index_type => 'string' , cargo => { type => 'leaf', value_type => 'string', }, }, ], rw_config => { backend => 'Json' , config_dir => '/tmp', file => 'foo.json', auto_create => 1, } ) ; my $inst = $model->instance(root_class_name => 'MyClass' ); my $root = $inst->config_root ; my $steps = 'foo=yada bar="bla bla" baz:en=hello baz:fr=bonjour baz:hr="dobar dan"'; $root->load( steps => $steps ) ; $inst->write_back ; Now, C contains: { "bar" : "bla bla", "foo" : "yada", "baz" : { "hr" : "dobar dan", "en" : "hello", "fr" : "bonjour" } } =head1 DESCRIPTION This module is used directly by L to read or write the content of a configuration tree written with Json syntax in C configuration tree. Note that undefined values are skipped for list element. I.e. if a list element contains C<('a',undef,'b')>, the data structure only contains C<'a','b'>. =head1 CONSTRUCTOR =head2 new Parameters: C<< ( node => $node_obj, name => 'Json' ) >> Inherited from L. The constructor is called by L. =head2 read Of all parameters passed to this read call-back, only C is used. This parameter must be a L. When a file is read, C returns 1. =head2 write Of all parameters passed to this write call-back, only C is used. This parameter must be L object. C returns 1. =head1 AUTHOR Dominique Dumont, (ddumont at cpan dot org) =head1 SEE ALSO L, L, L, =head1 AUTHOR Dominique Dumont =head1 COPYRIGHT AND LICENSE This software is Copyright (c) 2005-2022 by Dominique Dumont. This is free software, licensed under: The GNU Lesser General Public License, Version 2.1, February 1999 =cut Config-Model-2.149/lib/Config/Model/Backend/IniFile.pm0000644000175000017500000005447314170053137020673 0ustar domidomi# # This file is part of Config-Model # # This software is Copyright (c) 2005-2022 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 2.149; use Carp; use Mouse; use 5.10.0; use Config::Model::Exception; use File::Path; use Log::Log4perl qw(get_logger :levels); use base qw/Config::Model::Backend::Any/; use feature qw/postderef signatures/; no warnings qw/experimental::postderef experimental::signatures/; # change inherited attribute. See Moose::Manual::Attributes has '+node' => ( handles => ['load_data'], ); my $logger = get_logger("Backend::IniFile"); sub annotation { return 1; } ## no critic (Subroutines::ProhibitBuiltinHomonyms) sub read ($self, %args) { # args is: # object => $obj, # Config::Model::Node object # root => './my_test', # fake root directory, userd for tests # config_dir => /etc/foo', # absolute path # file => 'foo.conf', # file name # file_path => './my_test/etc/foo/foo.conf' # check => yes|no|skip return 0 unless $args{file_path}->exists; # no file to read my $section = ''; # dumb value used for logging my $delimiter = $args{comment_delimiter} || '#'; my $hash_class = $args{store_class_in_hash} || ''; my $section_map = $args{section_map} || {}; my $split_reg = $args{split_list_value}; my $check = $args{check} || 'yes'; my $assign_char = $args{assign_char} || '='; my $quote_value = $args{quote_value} || ''; my $obj = $self->node; my %force_lc; map { $force_lc{$_} = $args{"force_lc_$_"} ? 1 : 0; } qw/section key value/; #FIXME: Is it possible to store the comments with their location #in the file? It would be nice if comments that are after values #in input file, would be written in the same way in the output #file. Also, comments at the end of file are being ignored now. my @lines = $args{file_path}->lines_utf8; # try to get global comments (comments before a blank line) $self->read_global_comments( \@lines, $delimiter ); my @assoc = $self->associates_comments_with_data( \@lines, $delimiter ); # store INI data in a structure: # { # name => value leaf # name => [ value ] list # name => { key => value , ... } hash # name => { ... } node # name => [ { ... }, ... ] list of nodes # name => { key => { ... } , ... } hash of nodes # } my $ini_data = {}; my %ini_comment; my $section_ref = $ini_data; my $section_path = ''; foreach my $item (@assoc) { my ( $vdata, $comment ) = @$item; $logger->debug("ini read: reading '$vdata'"); my $comment_path; # Update section name if ( $vdata =~ /^\s*\[(.*)\]/ ) { $section = $force_lc{section} ? lc($1) : $1; my $remap = $section_map->{$section} || ''; if ( $remap eq '!' ) { # section_map maps section to root node $section_ref = $ini_data; $comment_path = $section_path = ''; $logger->debug("step 1: found node [$section]"); } elsif ($remap) { # section_map maps section to some node $section_ref = {}; $logger->debug("step 1: found node $remap [$section]"); $section_path = $comment_path = $self->set_or_push( $ini_data, $remap, $section_ref ); } elsif ($hash_class) { $ini_data->{$hash_class}{$section} = $section_ref = {}; $comment_path = $section_path = "$hash_class:$section"; $logger->debug("step 1: found node $hash_class and path $comment_path [$section]"); } else { $section_ref = {}; $logger->debug("step 1: found node $section [$section]"); $section_path = $comment_path = $self->set_or_push( $ini_data, $section, $section_ref ); } # for write later, need to store the obj if section map was used if ( defined $section_map->{$section} ) { $logger->debug("store section_map loc '$section_path' section '$section'"); $self->{reverse_section_map}{$section_path} = $section; } } else { my ( $name, $val ) = split( /\s*$assign_char\s*/, $vdata, 2 ); $name = lc($name) if $force_lc{key}; $val = lc($val) if $force_lc{value}; $val =~ s/"([^"]*)"/$1/g if $quote_value eq "shell_style"; $comment_path = $section_path . ' ' . $self->set_or_push( $section_ref, $name, $val ); $logger->debug("step 1: found node $comment_path name $name in [$section]"); } $ini_comment{$comment_path} = $comment if $comment; } my @load_args = ( data => $ini_data, check => $check ); push @load_args, split_reg => qr/$split_reg/ if $split_reg; $self->load_data(@load_args); while ( my ( $k, $v ) = each %ini_comment ) { my $item = $obj->grab( step => $k, mode => 'loose' ) or next; $item = $item->fetch_with_id(0) if $item->get_type eq 'list'; $logger->debug("annotate '$v' on ", $item->location); $item->annotation($v); } return 1; } sub set_or_push { my ( $self, $ref, $name, $val ) = @_; my $cell = $ref->{$name}; my $path; if ( defined $cell and ref($cell) eq 'ARRAY' ) { push @$cell, $val; $path = $name . ':' . $#$cell; } elsif ( defined $cell ) { $ref->{$name} = [ $cell, $val ]; $path = $name . ':1'; } else { $ref->{$name} = $val; $path = $name; # no way to distinguish between leaf and first value of list } return $path; } ## no critic (Subroutines::ProhibitBuiltinHomonyms) sub write ($self, %args) { # args is: # object => $obj, # Config::Model::Node object # root => './my_test', # fake root directory, userd for tests # config_dir => /etc/foo', # absolute path # file => 'foo.conf', # file name # file_path => './my_test/etc/foo/foo.conf' # check => yes|no|skip my $node = $args{object}; my $delimiter = $args{comment_delimiter} || '#'; croak "Undefined file handle to write" unless defined $args{file_path}; # use the first char of the list as a comment delimeter my $cc = substr($delimiter,0,1); $args{comment_delimiter} = $cc; my $res = ''; # some INI file have a 'General' section mapped in root node my $top_class_name = $self->{reverse_section_map}{''}; if ( defined $top_class_name ) { $logger->debug("writing class $top_class_name from reverse_section_map"); $res .= $self->write_data_and_comments( $cc, "[$top_class_name]" ); } $res .= $self->_write(%args); if ($res) { $args{file_path}->spew_utf8($self->write_global_comment( $cc ) . $res); } elsif ($self->auto_delete) { $args{file_path}->remove; } return; } sub _write_list{ my ($self, $args, $node, $elt) = @_ ; my $res = ''; my $join_list = $args->{join_list_value}; my $delimiter = $args->{comment_delimiter} || '#'; my $assign_with = $args->{assign_with} // $args->{assign_char} // ' = '; my $list_obj = $node->fetch_element($elt); my $list_obj_note = $list_obj->annotation; if ( $join_list ) { my @v = grep { length } $list_obj->fetch_all_values(); my $v = join( $join_list, @v ); if ( length($v) ) { $logger->debug("writing joined list elt $elt -> $v"); $res .= $self->write_data_and_comments( $delimiter, "$elt$assign_with$v", $list_obj_note ); } } else { foreach my $obj ( $list_obj->fetch_all('custom') ) { my $note = $obj->annotation; my $v = $self->_fetch_obj_value($args, $obj); if ( length $v ) { $logger->debug("writing list elt $elt -> $v"); $res .= $self->write_data_and_comments( $delimiter, "$elt$assign_with$v", $list_obj_note . $note ); } else { $logger->trace("NOT writing undef or empty list elt"); } } } return $res; } sub _write_check_list{ my ($self, $args, $node, $elt) = @_ ; my $res = ''; my $join_check_list = $args->{join_check_list_value}; my $delimiter = $args->{comment_delimiter} || '#'; my $assign_with = $args->{assign_with} // $args->{assign_char} // ' = '; my $obj = $node->fetch_element($elt); my $obj_note = $obj->annotation; if ($join_check_list ) { my $v = join( $join_check_list, $obj->get_checked_list() ); if ( length($v) ) { $logger->debug("writing check_list elt $elt -> $v"); $res .= $self->write_data_and_comments( $delimiter, "$elt$assign_with$v", $obj_note ); } } else { foreach my $v ( $obj->get_checked_list() ) { $logger->debug("writing joined check_list elt $elt -> $v"); $res .= $self->write_data_and_comments( $delimiter, "$elt$assign_with$v", $obj_note ); } } return $res; } sub _fetch_obj_value { my ($self, $args, $obj) = @_ ; my $v = $obj->fetch; if ( defined $args->{quote_value} and $args->{quote_value} eq 'shell_style' and defined $v and $v =~ /\s/ ) { $v = qq!"$v"!; } return $v; } sub _write_leaf { my ($self, $args, $node, $elt) = @_ ; my $res = ''; my $write_bool_as = $args->{write_boolean_as}; my $delimiter = $args->{comment_delimiter} || '#'; my $assign_with = $args->{assign_with} // $args->{assign_char} // ' = '; my $obj = $node->fetch_element($elt); my $obj_note = $obj->annotation; my $v = $self->_fetch_obj_value($args, $obj); if ( $write_bool_as and defined($v) and length($v) and $obj->value_type eq 'boolean' ) { $v = $write_bool_as->[$v]; } if ( defined $v and length $v ) { $logger->debug("writing leaf elt $elt -> $v"); $res .= $self->write_data_and_comments( $delimiter, "$elt$assign_with$v", $obj_note ); } else { $logger->trace("NOT writing undef or empty leaf elt"); } return $res; } sub _write_hash { my ($self, $args, $node, $elt) = @_ ; my $res = ''; my $delimiter = $args->{comment_delimiter} || '#'; my $obj = $node->fetch_element($elt); my $obj_note = $obj->annotation; foreach my $key ( $obj->fetch_all_indexes ) { my $hash_obj = $obj->fetch_with_id($key); my $note = $hash_obj->annotation; $logger->debug("writing hash elt $elt key $key"); my $subres = $self->_write( %$args, object => $hash_obj ); if ($subres) { $res .= "\n" . $self->write_data_and_comments( $delimiter, "[$key]", $obj_note . $note ) . $subres; } } return $res; } sub _write_node { my ($self, $args, $node, $elt) = @_ ; my $res = ''; my $delimiter = $args->{comment_delimiter} || '#'; my $obj = $node->fetch_element($elt); my $obj_note = $obj->annotation; $logger->debug("writing class $elt"); my $subres = $self->_write( %$args, object => $obj ); if ($subres) { # some INI file may have a section mapped to a node as exception to mapped in a hash my $exception_name = $self->{reverse_section_map}{ $obj->location }; if ( defined $exception_name ) { $logger->debug("writing class $exception_name from reverse_section_map"); } my $c_name = $exception_name || $elt; $res .= "\n" . $self->write_data_and_comments( $delimiter, "[$c_name]", $obj_note ) . $subres; } return $res; } sub _write ($self, %args) { my $node = $args{object}; my $delimiter = $args{comment_delimiter} || '#'; $logger->trace( "called on ", $node->name ); my $res = ''; # Using Config::Model::ObjTreeScanner would be overkill # first write list and element, then classes foreach my $elt ( $node->get_element_name ) { my $type = $node->element_type($elt); $logger->trace("first loop on elt $elt type $type"); next if $type =~ /node/ or $type eq 'hash'; if ( $type eq 'list' ) { $res .= $self->_write_list (\%args, $node, $elt) ; } elsif ( $type eq 'check_list') { $res .= $self->_write_check_list (\%args, $node, $elt) ; } elsif ( $type eq 'leaf' ) { $res .= $self->_write_leaf (\%args, $node, $elt) ; } else { Config::Model::Exception::Model->throw( error => "unexpected type $type for leaf elt $elt", object => $node ); } } foreach my $elt ( $node->get_element_name ) { my $type = $node->element_type($elt); $logger->trace("second loop on elt $elt type $type"); next unless $type =~ /node/ or $type eq 'hash'; my $obj = $node->fetch_element($elt); my $obj_note = $obj->annotation; if ( $type eq 'hash' ) { $res .= $self->_write_hash (\%args, $node, $elt) ; } else { $res .= $self->_write_node (\%args, $node, $elt) ; } } $logger->trace( "done on ", $node->name ); return $res; } no Mouse; __PACKAGE__->meta->make_immutable; 1; # ABSTRACT: Read and write config as a INI file __END__ =pod =encoding UTF-8 =head1 NAME Config::Model::Backend::IniFile - Read and write config as a INI file =head1 VERSION version 2.149 =head1 SYNOPSIS use Config::Model; my $model = Config::Model->new; $model->create_config_class ( name => "IniClass", element => [ [qw/foo bar/] => { type => 'list', cargo => {qw/type leaf value_type string/} } ] ); # model for free INI class name and constrained class parameters $model->create_config_class( name => "MyClass", element => [ ini_class => { type => 'hash', index_type => 'string', cargo => { type => 'node', config_class_name => 'IniClass' }, }, ], rw_config => { backend => 'IniFile', config_dir => '/tmp', file => 'foo.conf', store_class_in_hash => 'ini_class', auto_create => 1, } ); my $inst = $model->instance(root_class_name => 'MyClass' ); my $root = $inst->config_root ; $root->load('ini_class:ONE foo=FOO1 bar=BAR1 - ini_class:TWO foo=FOO2' ); $inst->write_back ; Now C contains: ## file written by Config::Model [ONE] foo=FOO1 bar=BAR1 [TWO] foo=FOO2 =head1 DESCRIPTION This module is used directly by L to read or write the content of a configuration tree written with INI syntax in C configuration tree. This INI file can have arbitrary comment delimiter. See the example in the SYNOPSIS that sets a semi-column as comment delimiter. By default the comment delimiter is '#' like in Shell or Perl. Note that undefined values are skipped for list element. I.e. when a list element contains C<('a',undef,'b')>, the data structure contains C<'a','b'>. =head1 Limitations =head2 Structure Structure of the Config::Model must be very simple. Either: =over =item * A single class with hash of leaves elements. =item * 2 levels of classes. The top level has nodes elements. All other classes have only leaf elements. =back =head1 Comments in Ini file This backend tries to read and write comments from configuration file. The comments are stored as annotation within the configuration tree. Comments extraction is based on best estimation as to which parameter the comment may apply. Wrong estimations are possible. =head1 CONSTRUCTOR =head2 new Parameters: C<< ( node => $node_obj, name => 'inifile' ) >> Inherited from L. The constructor is called by L. =head1 Parameters Optional parameters declared in the model: =head2 comment_delimiter Change the character that starts comments in the INI file. Default is 'C<#>'. Some Ini files allows comments to begin with several characters (e.g. C<#> or C<;>). In this case, set C to the possible characters (e.g "C<#;>"). The first character is used to write back comments. (In the example above, comment C<; blah> is written back as C<# blah>. =head2 store_class_in_hash See L =head2 section_map Is a kind of exception of the above rule. See also L =head2 force_lc_section Boolean. When set, sections names are converted to lowercase. =head2 force_lc_key Idem for key name =head2 force_lc_value Idem for all values. =head2 split_list_value Some INI values are in fact a list of items separated by a space or a comma. This parameter specifies the regex to use to split the value into a list. This applies only to C elements. =head2 join_list_value Conversely, the list element split with C needs to be written back with a string to join them. Specify this string (usually ' ' or ', ') with C. =head2 split_check_list_value Some INI values are in fact a check list of items separated by a space or a comma. This parameter specifies the regex to use to split the value read from the file into a list of items to check. This applies only to C elements. =head2 join_check_list_value Conversely, the check_list element split with C needs to be written back with a string to join them. Specify this string (usually ' ' or ', ') with C. =head2 write_boolean_as Array ref. Reserved for boolean value. Specify how to write a boolean value. Default is C<[0,1]> which may not be the most readable. C can be specified as C<['false','true']> or C<['no','yes']>. =head2 assign_char Character used to assign value in INI file. Default is C<=>. =head2 assign_with String used write assignment in INI file. Default is "C< = >". =head2 quote_value How to quote value in INI file. Currrently only C is supported for C. E.g. INI backend declaration can contain this parameter: quote_value => 'shell_style' Here are some example of quoted values. The 3 columns shows the original value in file, how it's stored internally and how it's written back: # read => shown => write "foo" => foo => "foo" "foo bar" => foo bar => "foo bar" "20"x"4" => 20x4 => "20x4" =head1 Mapping between INI structure and model INI file typically have the same structure with 2 different conventions. The class names can be imposed by the application or may be chosen by user. =head2 Imposed class name In this case, the class names must match what is expected by the application. The elements of each class can be different. For instance: foo = foo_v [ A ] bar = bar_v [ B ] baz = baz_v In this case, class C and class C do not use the same configuration class. The model has this structure: Root class |- leaf element foo |- node element A of class_A | \- leaf element bar \- node element B of class_B \- leaf element baz =head2 Arbitrary class name In this case, the class names can be chosen by the end user. Each class has the same elements. For instance: foo = foo_v [ A ] bar = bar_v1 [ B ] bar = bar_v2 In this case, class C and class C do not use the same configuration class. The model has this structure: Root class |- leaf foo \- hash element my_class_holder |- key A (value is node of class_A) | \- element-bar \- key B (value is node of class_A) \- element-bar In this case, the C name is specified in C with C parameter: rw_config => { backend => 'IniFile', config_dir => '/tmp', file => 'foo.ini', store_class_in_hash => 'my_class_holder', } Of course they are exceptions. For instance, in C, the C<[General]> INI class must be mapped to a specific node object. This can be specified with the C parameter: rw_config => } backend => 'IniFile', config_dir => '/tmp', file => 'foo.ini', store_class_in_hash => 'my_class_holder', section_map => { General => 'general_node', } } C can also map an INI class to the root node: rw_config => { backend => 'ini_file', store_class_in_hash => 'sections', section_map => { General => '!' }, } =head1 Handle key value files This backend is able to handle simple configuration files where the values are written as key value pairs like: foo = bar or foo: bar The option C is used to specify which character is used to assign a value in the file (white spaces are ignored). C is "C<=>" (the default) in the first example, and "C<:>" in the second. The C is used to control how the file is written back. E.g: foo=bar # the default foo= bar # assign_with is "= " foo = bar # assign_with is " = " foo:bar # assign_char is ':', assign_with is the default foo: bar # assign_char is ':', assign_with is ": " foo : bar # assign_char is ':', assign_with is " : " =head1 Methods =head2 read Of all parameters passed to this read call-back, only C is used. This parameter must be L object. It can also be undef. In this case, C returns 0. When a file is read, C returns 1. =head2 write Of all parameters passed to this write call-back, only C is used. This parameter must be a L object. C returns 1. =head1 AUTHOR Dominique Dumont, (ddumont at cpan dot org); Krzysztof Tyszecki, (krzysztof.tyszecki at gmail dot com) =head1 SEE ALSO L, L, L, =head1 AUTHOR Dominique Dumont =head1 COPYRIGHT AND LICENSE This software is Copyright (c) 2005-2022 by Dominique Dumont. This is free software, licensed under: The GNU Lesser General Public License, Version 2.1, February 1999 =cut Config-Model-2.149/lib/Config/Model/Backend/CdsFile.pm0000644000175000017500000001042414170053137020651 0ustar domidomi# # This file is part of Config-Model # # This software is Copyright (c) 2005-2022 by Dominique Dumont. # # This is free software, licensed under: # # The GNU Lesser General Public License, Version 2.1, February 1999 # package Config::Model::Backend::CdsFile 2.149; use 5.10.1; use Carp; use strict; use warnings; use Config::Model::Exception; use File::Path; use Log::Log4perl qw(get_logger :levels); use base qw/Config::Model::Backend::Any/; my $logger = get_logger("Backend::CdsFile"); sub read { my $self = shift; my %args = @_; # args is: # object => $obj, # Config::Model::Node object # root => './my_test', # fake root directory, userd for tests # config_dir => /etc/foo', # absolute path # file => 'foo.conf', # file name # file_path => './my_test/etc/foo/foo.conf' # check => yes|no|skip my $file_path = $args{file_path}; return 0 unless $file_path->exists; $logger->info("Read cds data from $file_path"); $self->node->load( step => $file_path->slurp_utf8 ); return 1; } sub write { my $self = shift; my %args = @_; # args is: # object => $obj, # Config::Model::Node object # root => './my_test', # fake root directory, userd for tests # config_dir => /etc/foo', # absolute path # file => 'foo.conf', # file name # file_path => './my_test/etc/foo/foo.conf' # check => yes|no|skip my $file_path = $args{file_path}; $logger->info("Write cds data to $file_path"); my $dump = $self->node->dump_tree( skip_auto_write => 'cds_file', check => $args{check} ); $file_path->spew_utf8($dump); return 1; } 1; # ABSTRACT: Read and write config as a Cds data structure __END__ =pod =encoding UTF-8 =head1 NAME Config::Model::Backend::CdsFile - Read and write config as a Cds data structure =head1 VERSION version 2.149 =head1 SYNOPSIS use Config::Model ; use Data::Dumper ; # define configuration tree object my $model = Config::Model->new ; $model ->create_config_class ( name => "MyClass", element => [ [qw/foo bar/] => { type => 'leaf', value_type => 'string' }, baz => { type => 'hash', index_type => 'string' , cargo => { type => 'leaf', value_type => 'string', }, }, ], rw_config => { backend => 'cds_file' , config_dir => '/tmp', file => 'foo.pl', auto_create => 1, } ) ; my $inst = $model->instance(root_class_name => 'MyClass' ); my $root = $inst->config_root ; my $steps = 'foo=yada bar="bla bla" baz:en=hello baz:fr=bonjour baz:hr="dobar dan"'; $root->load( steps => $steps ) ; $inst->write_back ; Now, C contains: { bar => 'bla bla', baz => { en => 'hello', fr => 'bonjour', hr => 'dobar dan' }, foo => 'yada' } =head1 DESCRIPTION This module is used directly by L to read or write the content of a configuration tree written with Cds syntax in C configuration tree. Note: =over 4 =item * Undefined values are skipped for list element. I.e. if a list element contains C<('a',undef,'b')>, the data structure contains C<'a','b'>. =item * Cds file is not created (and may be deleted) when no data is to be written. =back =head1 backend parameter =head2 config_dir Mandoatory parameter to specify where is the Cds configuration file. =head1 CONSTRUCTOR =head2 new Inherited from L. The constructor is called by L. =head2 read Of all parameters passed to this read call-back, only C is used. It can also be undef. In which case C returns 0. When a file is read, C returns 1. =head2 write Of all parameters passed to this write call-back, only C is used. C returns 1. =head1 AUTHOR Dominique Dumont, (ddumont at cpan dot org) =head1 SEE ALSO L, L, L, =head1 AUTHOR Dominique Dumont =head1 COPYRIGHT AND LICENSE This software is Copyright (c) 2005-2022 by Dominique Dumont. This is free software, licensed under: The GNU Lesser General Public License, Version 2.1, February 1999 =cut Config-Model-2.149/lib/Config/Model/Backend/PerlFile.pm0000644000175000017500000001116414170053137021044 0ustar domidomi# # This file is part of Config-Model # # This software is Copyright (c) 2005-2022 by Dominique Dumont. # # This is free software, licensed under: # # The GNU Lesser General Public License, Version 2.1, February 1999 # package Config::Model::Backend::PerlFile 2.149; use 5.10.1; use Carp; use strict; use warnings; use Config::Model::Exception; use File::Path; use Log::Log4perl qw(get_logger :levels); use base qw/Config::Model::Backend::Any/; my $logger = get_logger("Backend::PerlFile"); sub read { my $self = shift; my %args = @_; # args is: # object => $obj, # Config::Model::Node object # root => './my_test', # fake root directory, userd for tests # config_dir => /etc/foo', # absolute path # file => 'foo.conf', # file name # file_path => './my_test/etc/foo/foo.conf' # check => yes|no|skip my $file_path = $args{file_path}; return 0 unless -r $file_path; $file_path = "./$file_path" unless $file_path =~ m!^\.?/!; $logger->info("Read Perl data from $file_path"); my $pdata = do $file_path || die "Cannot open $file_path:$?"; $self->node->load_data($pdata); return 1; } sub write { my $self = shift; my %args = @_; # args is: # object => $obj, # Config::Model::Node object # root => './my_test', # fake root directory, userd for tests # config_dir => /etc/foo', # absolute path # file => 'foo.conf', # file name # file_path => './my_test/etc/foo/foo.conf' # check => yes|no|skip my $file_path = $args{file_path}; $logger->info("Write perl data to $file_path"); my $p_data = $self->node->dump_as_data( skip_auto_write => 'perl_file', check => $args{check} ); my $dumper = Data::Dumper->new( [$p_data] ); $dumper->Terse(1); $args{file_path}->spew_utf8( $dumper->Dump, ";\n" ); return 1; } 1; # ABSTRACT: Read and write config as a Perl data structure __END__ =pod =encoding UTF-8 =head1 NAME Config::Model::Backend::PerlFile - Read and write config as a Perl data structure =head1 VERSION version 2.149 =head1 SYNOPSIS use Config::Model ; use Data::Dumper ; # define configuration tree object my $model = Config::Model->new ; $model ->create_config_class ( name => "MyClass", element => [ [qw/foo bar/] => { type => 'leaf', value_type => 'string' }, baz => { type => 'hash', index_type => 'string' , cargo => { type => 'leaf', value_type => 'string', }, }, ], rw_config => { backend => 'perl_file' , config_dir => '/tmp', file => 'foo.pl', auto_create => 1, }, ) ; my $inst = $model->instance(root_class_name => 'MyClass' ); my $root = $inst->config_root ; my $steps = 'foo=yada bar="bla bla" baz:en=hello baz:fr=bonjour baz:hr="dobar dan"'; $root->load( steps => $steps ) ; $inst->write_back ; Now, C contains: { bar => 'bla bla', baz => { en => 'hello', fr => 'bonjour', hr => 'dobar dan' }, foo => 'yada' } =head1 DESCRIPTION This module is used directly by L to read or write the content of a configuration tree written with Perl syntax in C configuration tree. Note: =over 4 =item * Undefined values are skipped for list element. I.e. if a list element contains C<('a',undef,'b')>, the data structure contains C<'a','b'>. =item * Perl file is not created (and may be deleted) when no data is to be written. =back =head1 backend parameter =head2 config_dir Mandoatory parameter to specify where is the Perl configuration file. =head1 CONSTRUCTOR =head2 new Inherited from L. The constructor is called by L. =head2 read Of all parameters passed to this read call-back, only C is used. This parameter must be L object already opened for read. It can also be undef. In which case C returns 0. When a file is read, C returns 1. =head2 write Of all parameters passed to this write call-back, only C is used. This parameter must be a L object. C returns 1. =head1 AUTHOR Dominique Dumont, (ddumont at cpan dot org) =head1 SEE ALSO L, L, L, =head1 AUTHOR Dominique Dumont =head1 COPYRIGHT AND LICENSE This software is Copyright (c) 2005-2022 by Dominique Dumont. This is free software, licensed under: The GNU Lesser General Public License, Version 2.1, February 1999 =cut Config-Model-2.149/lib/Config/Model/Backend/Any.pm0000644000175000017500000003575114170053137020101 0ustar domidomi# # This file is part of Config-Model # # This software is Copyright (c) 2005-2022 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 2.149; 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 [qw/annotation auto_create auto_delete/] => ( is => 'ro', isa => 'Bool', default => 0 ); has 'node' => ( is => 'ro', isa => 'Config::Model::Node', weak_ref => 1, required => 1, handles => [ qw/show_message instance get_element_names/], ); sub skip_open { return 0; } sub read { my $self = shift; my $err = "Internal error: read not defined in backend $self->{name}."; $logger->error($err); croak $err; } sub write { my $self = shift; my $err = "Internal error: write not defined in backend $self->{name}."; $logger->error($err); croak $err; } sub read_global_comments { my $self = shift; my $lines = shift; my $cc = shift; # comment character(s) my $cc_re = length $cc > 1 ? "[$cc]" : $cc; my @global_comments; my @global_comment_lines; while ( defined( my $l = shift @$lines ) ) { next if $l =~ /^$cc_re{2}/; # remove comments added by Config::Model unshift @$lines, $l; last; } while ( defined( my $l = shift @$lines ) ) { next if $l =~ /^\s*$/; # remove empty lines unshift @$lines, $l; last; } while ( defined( my $l = shift @$lines ) ) { chomp $l; my ( $data, $comment ) = split /\s*$cc_re\s?/, $l, 2; if (defined $comment) { push @global_comment_lines, $l; push @global_comments, $comment; } if ( $l =~ /^\s*$/ ) { # we indeed had global comments which are now finished by # a blank line. Store them and bail out if (@global_comments) { $self->node->annotation(@global_comments); $logger->debug("Setting global comment with @global_comments on ", $self->node->name); } # stop global comment at first blank line last; } if ( $data ) { # The comment found is not global, put back line and any captured comment unshift @$lines, @global_comment_lines, $l; # stop global comment last; } } } sub associates_comments_with_data { my $self = shift; my $lines = shift; my $cc = shift; # comment character(s) my $cc_re = length $cc > 1 ? "[$cc]" : $cc; my @result; my @comments; foreach my $l (@$lines) { next if $l =~ /^$cc_re{2}/; # remove comments added by Config::Model chomp $l; my ( $data, $comment ) = split /\s*$cc_re\s?/, $l, 2; push @comments, $comment if defined $comment; next unless defined $data; $data =~ s/^\s+//g; $data =~ s/\s+$//g; if ($data) { my $note = ''; $note = join( "\n", @comments ) if @comments; $logger->trace("associates_comments_with_data: '$note' with '$data'"); push @result, [ $data, $note ]; @comments = (); } } return wantarray ? @result : \@result; } sub write_global_comment { goto &write_global_comments; } sub write_global_comments { my $self = shift; my ($ioh, $cc); if (ref($_[0])) { my ($package, $filename, $line) = caller; $logger->warn("write_global_comments: io_handle parameter is deprecated ($filename: $line)"); ($ioh, $cc) = @_; } else { ( $cc ) = @_; } croak "write_global_comments: no comment char specified" unless $cc; # no need to mention 'cme list' if current application is found my $app = $self->node->instance->application ; my $extra = '' ; if (not $app) { $extra = "$cc$cc Run 'cme list' to get the list of applications" . " available on your system\n"; $app = ''; } my $res = "$cc$cc This file was written by cme command.\n" . "$cc$cc You can run 'cme edit $app' to modify this file.\n" . $extra . "$cc$cc You may also modify the content of this file with your favorite editor.\n\n"; # write global comment my $global_note = $self->node->annotation; if ($global_note) { for ( split /\n/, $global_note ) { $res .= "$cc $_\n" } $res .= "\n"; } $ioh->print($res) if defined $ioh; return $res; } # $cc can be undef when writing a list on a single line sub write_data_and_comments { my $self = shift; my ($ioh, $cc, @data_and_comments); if (not defined $_[0] or ref($_[0])) { $logger->warn("write_data_and_comments: io_handle parameter is deprecated"); ($ioh, $cc, @data_and_comments) = @_; } else { ( $cc, @data_and_comments ) = @_; } my $res = ''; while (@data_and_comments) { my ( $d, $c ) = splice @data_and_comments, 0, 2; if ($c) { for (split /\n/, $c ) { $res .= "$cc $_\n" } } $res .= "$d\n" if defined $d; } $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.149 =head1 SYNOPSIS package Config::Model::Backend::Foo ; use Mouse ; extends 'Config::Model::Backend::Any'; # mandatory sub read { my $self = shift ; my %args = @_ ; # args are: # root => './my_test', # fake root directory, used for tests # config_dir => /etc/foo', # absolute path # file => 'foo.conf', # file name # file_path => Path::Tiny object for './my_test/etc/foo/foo.conf' # check => yes|no|skip return 0 unless $args{file_path}->exists ; # or die, your choice # read the file line by line # we assume the file contain lines like 'key=value' foreach ($args{file_path}->lines_utf8) { chomp ; # remove trailing \n s/#.*// ; # remove any comment next unless /\S/; # skip blank line # $data is 'foo=bar' which is compatible with load $self->node->load(steps => $_, check => $args{check} ) ; } return 1 ; } # mandatory sub write { my $self = shift ; my %args = @_ ; # args are: # root => './my_test', # fake root directory, used for tests # config_dir => /etc/foo', # absolute path # file => 'foo.conf', # file name # file_path => Path::Tiny object for './my_test/etc/foo/foo.conf' # check => yes|no|skip # read the content of the configuration tree my @lines; foreach my $elt ($self->node->children) { # read the value from element $elt my $v = $self->node->grab_value($elt) ; # write value in file push @lines,qq!$elt="$v"\n! if defined $v ; } $args{file_path}->spew_utf8(@lines); return 1; } =head1 DESCRIPTION Some application have configuration files with a syntax which is not supported by existing C classes. In this case a new backend must be written. C was created to facilitate this task. The new backend class must use L and must extends (inherit) C. =head1 How to write your own backend =head2 Declare the new backend in a node of the model As explained in L, the new backend must be declared as an attribute of a L specification. Let's say your new backend is C. This new backend can be specified with: rw_config => { backend => 'Foo' , # can also be 'foo' config_dir => '/etc/cfg_dir' file => 'foo.conf', # optional } (The backend class name is constructed with C) C can also have custom parameters that are passed verbatim to C methods: rw_config => { backend => 'Foo' , # can also be 'foo' config_dir => '/etc/cfg_dir' file => 'foo.conf', # optional my_param => 'my_value', } C class must inherit (extend) L and is expected to provide the following methods: =over =item read C is called with the following parameters: %custom_parameters, # e.g. my_param => 'my_value' in the example above object => $obj, # Config::Model::Node object root => $root_dir, # fake root directory, used for tests backend => $backend, # backend name config_dir => $read_dir, # path below root file => 'foo.conf', # file name file_path => $full_name, # Path::Tiny object check => [yes|no|skip] The L object is undef if the file cannot be read. This method must return 1 if the read was successful, 0 otherwise. Following the C example above, C<%custom_parameters> contains C< ( 'my_param' , 'my_value' ) >, so C is called with C, C, C B C<< my_param => 'my_value' >>. =item write C is called with the following parameters: %$custom_parameters, # e.g. my_param => 'my_value' in the example above object => $obj, # Config::Model::Node object root => $root_dir, # fake root directory, used for tests auto_create => $auto_create, # boolean specified in backend declaration auto_delete => $auto_delete, # boolean specified in backend declaration backend => $backend, # backend name config_dir => $write_dir, # override from instance file => 'foo.conf', # file name file_path => $full_name, # full file name (root+path+file) write => 1, # always check => [ yes|no|skip] , backup => [ undef || '' || suffix ] # backup strategy required by user The L object is undef if the file cannot be written to. This method must return 1 if the write was successful, 0 otherwise =back =head2 How to test your new backend Using L, you can test your model with your backend following the instructions given in L. You can also test your backend with a minimal model (and L). In this case, you need to specify a small model to test in a C<*-test-conf.pl> file. See the L for an example and its L. =head1 CONSTRUCTOR =head2 new The constructor should be used only by L. Parameter: =over =item node Calling node object. Node ref is weakened, =item name Backend name =item auto_create Boolean. Set to true to create the configuration file if this one is missing (default 0) =item auto_delete Boolean. Set to true to remove the configuration file if this one no longer contain configuration information. (default 0) =back =head1 Methods to override =head2 annotation Whether the backend supports reading and writing annotation (a.k.a comments). Default is 0. Override this method to return 1 if your backend supports annotations. =head2 read Read the configuration file. This method must be overridden. =head2 write Write the configuration file. This method must be overridden. =head1 Methods =head2 node Return the node (a L) holding this backend. =head2 instance Return the instance (a L) holding this configuration. =head2 show_message Parameters: C<( string )> Show a message to STDOUT (unless overridden). Delegated to L. =head2 read_global_comments Parameters: =over =item * array ref of string containing the lines to be parsed =item * A string to specify how a comment is started. Each character is recognized as a comment starter (e.g 'C<#;>' allow a comment to begin with 'C<#>' or 'C<;>') =back Read the global comments (i.e. the first block of comments until the first blank or non comment line) and store them as root node annotation. Note that the global comment must be separated from the first data line by a blank line. Example: $self->read_global_comments( \@lines, ';'); $self->read_global_comments( \@lines, '#;'); =head2 associates_comments_with_data Parameters: =over =item * array ref of string containing the lines to be parsed =item * A string to specify how a comment is started. Each character is recognized as a comment starter (e.g 'C<#;>' allow a comment to begin with 'C<#>' or 'C<;>') =back This method extracts comments from the passed lines and associate them with actual data found in the file lines. Data is associated with comments preceding or on the same line as the data. Returns a list of [ data, comment ]. Example: my @lines = ( '# Foo comments', 'foo= 1', 'Baz = 0 # Baz comments' ); my @res = $self->associates_comments_with_data( \@lines, '#') # @res is: # ( [ 'foo= 1', 'Foo comments' ] , [ 'Baz = 0' , 'Baz comments' ] ) =head2 write_global_comments Return a string containing global comments using data from configuration root annotation. Requires one parameter: comment_char (e.g "#" or '//' ) Example: my $str = $self->write_global_comments('#') =head2 write_data_and_comments Returns a string containing comments (stored in annotation) and corresponding data. Comments are written before the data. If a data is undef, the comment is written on its own line. Positional parameters are C<( comment_char , data1, comment1, data2, comment2 ...)> Example: print $self->write_data_and_comments('#', 'foo', 'foo comment', undef, 'lone comment','bar') # returns "# foo comment\nfoo\n#lon Use C as comment char if comments are not supported by the syntax of the configuration file. Comments will then be dropped. =head1 Replacing a custom backend Custom backend are now deprecated and must be replaced with a class inheriting this module. Please: =over =item * Rename your class to begin with C =item * Add C and C in the header of your custom class. =item * Add C as the beginning of C and C functions... well... methods. =back Here's an L. =head1 AUTHOR Dominique Dumont, (ddumont at cpan dot org) =head1 SEE ALSO L, L, L, =head1 AUTHOR Dominique Dumont =head1 COPYRIGHT AND LICENSE This software is Copyright (c) 2005-2022 by Dominique Dumont. This is free software, licensed under: The GNU Lesser General Public License, Version 2.1, February 1999 =cut Config-Model-2.149/lib/Config/Model/Backend/ShellVar.pm0000644000175000017500000001236314170053137021064 0ustar domidomi# # This file is part of Config-Model # # This software is Copyright (c) 2005-2022 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 2.149; use Carp; use Mouse; use Config::Model::Exception; use File::Path; use Log::Log4perl qw(get_logger :levels); use Config::Model::BackendTrackOrder; extends 'Config::Model::Backend::Any'; my $logger = get_logger("Backend::ShellVar"); has tracker => ( is => 'ro', isa => 'Config::Model::BackendTrackOrder', lazy_build => 1, handles => [qw/get_ordered_element_names/], ); sub _build_tracker { my $self = shift; return Config::Model::BackendTrackOrder->new( backend_obj => $self, node => $self->node, ) ; } sub annotation { return 1; } sub read { my $self = shift; my %args = @_; # args are: # object => $obj, # Config::Model::Node object # root => './my_test', # fake root directory, userd for tests # config_dir => /etc/foo', # absolute path # file => 'foo.conf', # file name # file_path => './my_test/etc/foo/foo.conf' # check => yes|no|skip return 0 unless $args{file_path}->exists; # no file to read my $check = $args{check} || 'yes'; my @lines = $args{file_path}->lines_utf8; # try to get global comments (comments before a blank line) $self->read_global_comments( \@lines, '#' ); my @assoc = $self->associates_comments_with_data( \@lines, '#' ); foreach my $item (@assoc) { my ( $data, $c ) = @$item; my ($k,$v) = split /\s*=\s*/, $data, 2; # make reader quite tolerant $v =~ s/^["']|["']$//g; if ($logger->is_debug) { my $msg = "Loading key '$k' value '$v'"; $msg .= " comment: '$c'" if $c; $logger->debug($msg); } $self->tracker->register_element($k); my $obj = $self->node->fetch_element($k); $obj->store( value => $v, check => $check ); $obj->annotation($c) if $c; } return 1; } sub write { my $self = shift; my %args = @_; # args are: # object => $obj, # Config::Model::Node object # root => './my_test', # fake root directory, userd for tests # config_dir => /etc/foo', # absolute path # file => 'foo.conf', # file name # file_path => './my_test/etc/foo/foo.conf' # check => yes|no|skip my $node = $args{object}; my @to_write; # Using Config::Model::ObjTreeScanner would be overkill foreach my $elt ( $self->get_ordered_element_names ) { my $obj = $node->fetch_element($elt); my $v = $node->grab_value($elt); next unless defined $v; push @to_write, [ qq!$elt="$v"!, $obj->annotation ]; } if (@to_write) { my $res = $self->write_global_comment( '#' ); foreach my $line_ref (@to_write) { $res .= $self->write_data_and_comments( '#', @$line_ref ); } $args{file_path}->spew_utf8($res); } return 1; } no Mouse; __PACKAGE__->meta->make_immutable; 1; # ABSTRACT: Read and write config as a C data structure __END__ =pod =encoding UTF-8 =head1 NAME Config::Model::Backend::ShellVar - Read and write config as a C data structure =head1 VERSION version 2.149 =head1 SYNOPSIS use Config::Model; my $model = Config::Model->new; $model->create_config_class ( name => "MyClass", element => [ [qw/foo bar/] => {qw/type leaf value_type string/} ], rw_config => { backend => 'ShellVar', config_dir => '/tmp', file => 'foo.conf', auto_create => 1, } ); my $inst = $model->instance(root_class_name => 'MyClass' ); my $root = $inst->config_root ; $root->load('foo=FOO1 bar=BAR1' ); $inst->write_back ; File C now contains: ## This file was written by Config::Model ## You may modify the content of this file. Configuration ## modifications will be preserved. Modifications in ## comments may be mangled. ## foo="FOO1" bar="BAR1" =head1 DESCRIPTION This module is used directly by L to read or write the content of a configuration tree written with C syntax in C configuration tree. Note that undefined values are skipped for list element. I.e. if a list element contains C<('a',undef,'b')>, the data structure contains C<'a','b'>. =head1 CONSTRUCTOR =head2 new Parameters: C<< ( node => $node_obj, name => 'shellvar' ) >> Inherited from L. The constructor is called by L. =head2 read Of all parameters passed to this read call-back, only C is used. When a file is read, C returns 1. =head2 write Of all parameters passed to this write call-back, only C is used. C returns 1. =head1 AUTHOR Dominique Dumont, (ddumont at cpan dot org) =head1 SEE ALSO L, L, L, =head1 AUTHOR Dominique Dumont =head1 COPYRIGHT AND LICENSE This software is Copyright (c) 2005-2022 by Dominique Dumont. This is free software, licensed under: The GNU Lesser General Public License, Version 2.1, February 1999 =cut Config-Model-2.149/lib/Config/Model/Backend/PlainFile.pm0000644000175000017500000002223714170053137021210 0ustar domidomi# # This file is part of Config-Model # # This software is Copyright (c) 2005-2022 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 2.149; use 5.10.1; use Carp; use Mouse; use Config::Model::Exception; use Path::Tiny; use Log::Log4perl qw(get_logger :levels); extends 'Config::Model::Backend::Any'; with "Config::Model::Role::ComputeFunction"; with "Config::Model::Role::FileHandler"; my $logger = get_logger("Backend::PlainFile"); sub annotation { return 0; } # remember that a read backend (and its config file(s)) is attached to a node # OTOH, PlainFile backend deal with files that are attached to elements of a node. # Hence the files must not be managed by backend manager. # file not opened by BackendMgr # file_path is undef sub skip_open { 1; } sub get_file_name { my ($self, %args) = @_; my $obj = $args{object}->fetch_element( name => $args{elt} ); return $args{file} ? $obj->compute_string($args{file}) : $args{elt}; } sub read { my $self = shift; my %args = @_; # args are: # object => $obj, # Config::Model::Node object # root => './my_test', # fake root directory, userd for tests # config_dir => /etc/foo', # absolute path # file => 'foo.conf', # file name # file_path => './my_test/etc/foo/foo.conf' # check => yes|no|skip my $check = $args{check} || 'yes'; my $node = $args{object}; $logger->trace( "called on node ", $node->name ); # read data from leaf element from the node # do not trigger warp when getting element names foreach my $elt ( $node->get_element_names(all => 1) ) { my $obj = $args{object}->fetch_element( name => $elt ); my $file_name = $self->get_file_name(%args, elt => $elt); my $dir = $self->get_tuned_config_dir(%args); my $file = $dir->child($file_name); $logger->trace("looking for plainfile $file for ", $obj->location); my $type = $obj->get_type; if ( $type eq 'leaf' ) { $self->read_leaf( $obj, $elt, $check, $file, \%args ); } elsif ( $type eq 'list' ) { $self->read_list( $obj, $elt, $check, $file, \%args ); } elsif ( $type eq 'hash' ) { $self->read_hash( $obj, $elt, $check, $file, \%args ); } else { $logger->debug("PlainFile read skipped $type $elt"); } } return 1; } sub read_leaf { my ( $self, $obj, $elt, $check, $file, $args ) = @_; return unless $file->exists; my $v = $file->slurp_utf8; chomp($v) unless $obj->value_type eq 'string'; if ($logger->is_trace) { (my $str = $v) =~ s/\n.*/[...]/s; $logger->trace("storing leaf value '$str' from $file "); } $obj->store( value => $v, check => $check ); } sub read_list { my ( $self, $obj, $elt, $check, $file, $args ) = @_; return unless $file->exists; my @v = $file->lines_utf8({ chomp => 1}); $logger->trace("storing list value @v from $file "); $obj->store_set(@v); } 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' # check => yes|no|skip my $check = $args{check} || 'yes'; my $cfg_dir = $args{config_dir}; my $dir = $self->get_tuned_config_dir(%args); $dir->mkpath({ mode => oct(755) } ) unless $dir->is_dir; my $node = $args{object}; $logger->debug( "PlainFile write called on node ", $node->name ); # write data from leaf element from the node foreach my $elt ( $node->get_element_name() ) { my $obj = $args{object}->fetch_element( name => $elt ); my $file_name = $self->get_file_name(%args, elt => $elt); my $file = $dir->child($file_name); my $type = $obj->get_type; my @v; if ( $type eq 'leaf' ) { my $v = $obj->fetch( check => $args{check} ); $v .= "\n" if defined $v and $obj->value_type ne 'string'; push @v, $v if defined $v; } elsif ( $type eq 'list' ) { @v = map { "$_\n" } $obj->fetch_all_values; } else { $logger->debug("PlainFile write skipped $type $elt"); next; } if (@v) { $logger->trace("PlainFile write opening $file to write $elt"); $file->spew_utf8(@v); $file->chmod($args{file_mode}) if $args{file_mode}; } elsif ($file->exists) { $logger->trace("PlainFile delete $file"); $file->remove; } } return 1; } sub delete { 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' # check => yes|no|skip my $dir = $self->get_tuned_config_dir(%args); my $node = $args{object}; $logger->debug( "PlainFile delete called on deleted node"); # write data from leaf element from the node foreach my $elt ( $node->get_element_name() ) { my $obj = $node->fetch_element( name => $elt ); my $file_name = $self->get_file_name(%args, elt => $elt); my $file = $dir->child( $file_name ); $logger->info( "Removing $file (deleted node)" ); $file->remove; } } 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.149 =head1 SYNOPSIS use Config::Model; my $model = Config::Model->new; my $inst = $model->create_config_class( name => "WithPlainFile", element => [ [qw/source new/] => { qw/type leaf value_type uniline/ }, ], rw_config => { backend => 'plain_file', config_dir => '/tmp', }, ); my $inst = $model->instance(root_class_name => 'WithPlainFile' ); my $root = $inst->config_root ; $root->load('source=foo new=yes' ); $inst->write_back ; Now C directory contains 2 files: C and C with C and C inside. =head1 DESCRIPTION This module is used directly by L to read or write the content of a configuration tree written in several files. Each element of the node is written in a plain file. =head1 Element type and file mapping Element values are written in one or several files depending on their type. =over =item leaf The leaf value is written in one file. This file can have several lines if the leaf type is C =item list The list content is written in one file. Each line of the file is a value of the list. =item hash Not supported =back =head1 File mapping By default, the configuration file is named after the element name (like in synopsis above). The C parameter can also be used to specify a file name that take into account the path in the tree using C<&index()> and C<&element()> functions from L. For instance, with the following model: class_name => "Foo", element => [ string_a => { type => 'leaf', value_type => 'string'} string_b => { type => 'leaf', value_type => 'string'} ], rw_config => { backend => 'PlainFile', config_dir => 'foo', file => '&element(-).&element', file_mode => 0644, # optional } If the configuration is loaded with C, this backend writes "C" in file C and C in file C. C parameter can be used to set the mode of the written file. C value can be in any form supported by L. =head1 Methods =head2 read_leaf Parameters: C<(obj, elt, check, file, args)> Called by L method to read the file of a leaf element. C contains the arguments passed to L method. =head2 read_hash (obj,elt,check,file,args); Like L for hash elements. =head2 read_list Parameters: C<(obj, elt, check, file, args)> Like L for list elements. =head2 write C writes a file for each element of the calling class. Works only for leaf and list elements. Other element type are skipped. Always return 1 (unless it died before). =head1 AUTHOR Dominique Dumont, (ddumont at cpan dot org) =head1 SEE ALSO L, L, L, =head1 AUTHOR Dominique Dumont =head1 COPYRIGHT AND LICENSE This software is Copyright (c) 2005-2022 by Dominique Dumont. This is free software, licensed under: The GNU Lesser General Public License, Version 2.1, February 1999 =cut Config-Model-2.149/lib/Config/Model/TreeSearcher.pm0000644000175000017500000001425614170053137020374 0ustar domidomi# # This file is part of Config-Model # # This software is Copyright (c) 2005-2022 by Dominique Dumont. # # This is free software, licensed under: # # The GNU Lesser General Public License, Version 2.1, February 1999 # package Config::Model::TreeSearcher 2.149; use Mouse; use Mouse::Util::TypeConstraints; use List::MoreUtils qw/any/; 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->trace( "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 any { $_ =~ $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; for ( qw/description summary/ ) { if ($need_search->{$_} and $node->get_help_as_text( $_ => $e ) =~ $reg) { $store = 1; } } if ($need_search->{element} and $e =~ $reg) { $store = 1; } $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->trace("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.149 =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 $steps = 'baz:fr=bonjour baz:hr="dobar dan" foo="journalled"'; $root->load( steps => $steps ) ; 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 scans 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 Parameters: C<< (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 elements. 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-2022 by Dominique Dumont. This is free software, licensed under: The GNU Lesser General Public License, Version 2.1, February 1999 =cut Config-Model-2.149/lib/Config/Model/application.d/0000755000175000017500000000000014170053137020177 5ustar domidomiConfig-Model-2.149/lib/Config/Model/application.d/multistrap0000644000175000017500000000005314170053137022324 0ustar domidomimodel = Multistrap require_config_file = 1 Config-Model-2.149/lib/Config/Model/Cookbook/0000755000175000017500000000000014170053137017220 5ustar domidomiConfig-Model-2.149/lib/Config/Model/Cookbook/CreateModelFromDoc.pod0000644000175000017500000002201114170053137023356 0ustar domidomi# 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.149 =head1 Introduction This page shows step by step how was created C's model from C documentation provided as comments in C's sample configuration file. =head1 C configuration file A quick looks in C directory shows that C's configuration is stored in C: # Config file for Debian's popularity-contest package. # # To change this file, use: # dpkg-reconfigure popularity-contest # # You can also edit it by hand, if you so choose. # # See /usr/share/popularity-contest/default.conf for more info # on the options. MY_HOSTID="172921501FFFFFAAAA6897etc" PARTICIPATE="yes" USEHTTP="yes" DAY="5" The important part is the mention of C which contains all the required information to create C's configuration model. =head1 C documentation Let's start from C file. Since this file is loaded by C I loading C, all values there can be used as application default values (aka I): # Default config file for Debian's popularity-contest package. # # Local overrides are in /etc/popularity-contest.conf # PARTICIPATE can be one of "yes" or "no". # If you don't want to participate in the contest, say "no" # and we won't send messages. # # If this option is missing, the default is "no". # PARTICIPATE="no" # MAILTO specifies the address to e-mail statistics to each week. # MAILTO="survey@popcon.debian.org" # MAILFROM is the forged sender email address you want to use in # email submitted to the popularity-contest. If this is commented # out, no From: or Sender: lines will be added to the outgoing mail, # and it will be your MTA's job to add them. This is usually what # you want. # # If your MTA is misconfigured or impossible to configure correctly, # and it always generates invalid From: and/or Sender: lines, you # can force different results by setting MAILFROM here. This can # cause problems with spam bouncers, so most people should leave it # commented out. # #MAILFROM="root@example.org" # SUBMITURLS is a space separated list of where to submit # popularity-contest reports using http. SUBMITURLS="http://popcon.debian.org/cgi-bin/popcon.cgi" # USEHTTP enables http reporting. Set this to 'yes' to enable it. USEHTTP="yes" # HTTP_PROXY allows one to specify an HTTP proxy server, the syntax is # HTTP_PROXY="http://proxy:port". This overrides the environment # variable http_proxy. # MY_HOSTID is a secret number that the popularity-contest receiver # uses to keep track of your submissions. Whenever you send in a # new entry, it overwrites the last one that had the same HOSTID. # # This key was generated automatically so you should normally just # leave it alone. # #MY_HOSTID="_ID_" This file contains everything we need: =over =item * Parameter names =item * Documentation =item * Default values =back Now, we will use our favorite editor to edit this file and add YAML tags that can be understood by C =head1 Creating the YAML skeleton C is able to load a model described in YAML. To do this the above file needs to be translated in YAML. That's not as complicated as it may sound. First, a YAML file must begin with B<--->. Then the class must be declared: --- class: PopCon: Note that, like with Python language, the indentation is important to define the structure of the file. Here, the C class is followed by a ':' as it defines a new hierarchical level to describes the configuration elements of this class: element: Now we can deal with the configuration parameters. Let's detail the C element. Here's the spec in from C: # PARTICIPATE can be one of "yes" or "no". # If you don't want to participate in the contest, say "no" # and we won't send messages. # # If this option is missing, the default is "no". # PARTICIPATE="no" In the YAML file, the comments are moved in the C field and the value in the file is used as upstream default: PARTICIPATE: upstream_default: no description: > If you don't want to participate in the contest, say "no" and we won't send messages. Likewise for the remaining parameters: MAILTO: description: > specifies the address to e-mail statistics to each week. default: 'survey@popcon.debian.org' MAILFROM: description: >- MAILFROM is the forged sender email address you want to use in email submitted to the popularity-contest. If this is commented out, no From: or Sender: lines will be added to the outgoing mail, and it will be your MTA's job to add them. This is usually what you want. If your MTA is misconfigured or impossible to configure correctly, and it always generates invalid From: and/or Sender: lines, you can force different results by setting MAILFROM here. This can cause problems with spam bouncers, so most people should leave it commented out. In the description above, the C marker '-' after '>' is used to keep paragraph formatting in the help. SUBMITURLS: description: > Space separated list of where to submit popularity-contest reports using http. default: > http://popcon.debian.org/cgi-bin/popcon.cgi USEHTTP: description: > enables http reporting. Set this to 'yes' to enable it. default: "yes" HTTP_PROXY: description: > allows one to specify an HTTP proxy server, the syntax is "http://proxy:port". This overrides the environment variable http_proxy. MY_HOSTID: description: >- secret number that the popularity-contest receiver uses to keep track of your submissions. Whenever you send in a new entry, it overwrites the last one that had the same HOSTID. This key was generated automatically so you should normally just leave it alone. =head1 Loading the YAML skeleton Now that the YAML file was created, you can turn it into a model and load it in the model editor GUI with the following command: cme meta edit popcon -load-yaml popcon.yml -force Note that the model is incomplete: some mandatory parameters are missing from the YAML file so the I<-force> option must be used. These missing parameters are also flagged with a red cross in the GUI. =head1 Completing missing model parts To complete the model, the easiest way is to run the wizard to complete the missing values. In the GUI, you can use the menu C<< File -> wizard >> to launch the wizard. Then click on the 'OK' button in the new window. The wizard will first stop on the parameter list (not because there's an error, but because the parameter list is flagged as I) There, you can re-order the parameters by selecting one and clicking on one of the blue arrows to move it up or down. Once you're satisfied, click on I. The widget will now stop on the first missing information. Just select the correct type ('leaf' here), click 'store' and 'Next'. You can repeat these steps until the wizard exits. =head1 Specifying read and write backend Once the model is complete, it's time to specify how to read and write the file. In C class specification: =over =item * right-click on I =item * click on I to create a new read specification =item * right-click on the created item (shown at index "I<0>") =back You will get a window showing you the parameters to fill to specify the read backend. Now fill the blank on the right side. The backend to use is C since I is made of shell variables. Since the write specification is identical, there's no need to specify it. L will do the right thing. =head1 Testing the model You can test the model by clicking on menu C<< Test -> Model >>. You will be shown the C configuration editor GUI. The same that your users will get. If everything is fine, you can quit the model editor (menu File->quit) =head1 The resulting model The model you have just created is stored in C. You can test directly this model with : cme edit -dev -try Popcon =head1 Feedback welcome Feel free to send comments and suggestion about this page to the author. =head1 AUTHORS Dominique Dumont =head1 AUTHOR Dominique Dumont =head1 COPYRIGHT AND LICENSE This software is Copyright (c) 2005-2022 by Dominique Dumont. This is free software, licensed under: The GNU Lesser General Public License, Version 2.1, February 1999 =cut Config-Model-2.149/lib/Config/Model/Node.pm0000644000175000017500000015717014170053137016710 0ustar domidomi# # This file is part of Config-Model # # This software is Copyright (c) 2005-2022 by Dominique Dumont. # # This is free software, licensed under: # # The GNU Lesser General Public License, Version 2.1, February 1999 # package Config::Model::Node 2.149; use Mouse; with "Config::Model::Role::NodeLoader"; use Carp; use 5.020; use Config::Model::TypeConstraints; use Config::Model::Instance; 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/; with "Config::Model::Role::Grab"; with "Config::Model::Role::HelpAsText"; with "Config::Model::Role::ComputeFunction"; with "Config::Model::Role::Constants"; with "Config::Model::Role::Utils"; use feature qw/signatures postderef/; no warnings qw/experimental::signatures experimental::postderef/; 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"); my $deep_check_logger = get_logger('DeepCheck'); my $user_logger = get_logger('User'); # 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 gist => ( is => 'rw', isa => 'Str', default => '', ); sub fetch_gist { my $self = shift; my $gist = $self->gist // ''; $gist =~ s!{([\w -]+)}!$self->grab($1)->fetch // ''!ge; return $gist; } has config_file => ( is => 'ro', isa => 'Config::Model::TypeContraints::Path', required => 0 ); has element_name => ( is => 'ro', isa => 'Maybe[Str]', required => 0 ); has instance => ( is => 'ro', isa => 'Config::Model::Instance', weak_ref => 1, required => 1, handles => [qw/read_check/], ); has config_model => ( is => 'ro', isa => 'Config::Model', weak_ref => 1, lazy => 1, builder => '_config_model' ); sub _config_model { my $self = shift; return $self->instance->config_model; } 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]' ); # used to avoid warning twice about a deprecated element. Internal methods has warned_deprecated_element => ( is => 'ro', isa => 'HashRef[Str]', traits => ['Hash'], default => sub { {}; }, handles => { warn_element_done => 'set', was_element_warned => 'defined', } ) ; # attribute is defined in Config::Model::Anything 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 $caller_class = defined $self->parent ? $self->parent->name : 'user'; my $class_name = $self->config_class_name; $logger->debug("New $class_name requested by $caller_class"); $self->{original_model} = $self->config_model->model($class_name); $self->model( dclone($self->{original_model}) ) ; $self->check_properties; return $self; } ## Create_* methods are all internal and should not be used directly sub create_element ($self, @args) { my %args = _resolve_arg_shortcut(\@args, 'name'); 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, 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; return $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, parent => $self, container => $self, ); return $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; return $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}; return $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}; return $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)\n" 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} // get_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}; } } return; } sub init ($self, @args) { return if $self->{initialized}; $self->{initialized} = 1; # avoid recursions my $model = $self->{model}; return unless defined $model->{rw_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, rw_config => $model->{rw_config} ); $self->read_config_data( check => $self->read_check ); # setup auto_write $self->backend_mgr->auto_write_init(); $self->instance->initial_load($initial_load_backup); return; } 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 # may use an overridden config file return $self->backend_mgr->read_config_data( check => $args{check}, config_file => $args{config_file} || $self->{config_file}, auto_create => $args{auto_create} || $self->instance->auto_create, ); } around notify_change => sub ($orig, $self, %args) { if ($change_logger->is_trace) { my @with = map { "'$_' -> '". ($args{$_} // '') ."'" } sort keys %args; $change_logger->trace("called for ", $self->name, " from ", join( ' ', caller ), " with ", join( ' ', @with )); } return if $self->instance->initial_load and not $args{really}; $logger->trace( "called while needs_write is ", $self->needs_save, " for ", $self->name ) if $logger->is_trace; if ( defined $self->backend_mgr ) { $self->needs_save(1); # will trigger a save in config_file $self->$orig( %args, needs_save => 0 ); } else { # save config_file will be done by a node above $self->$orig( %args, needs_save => 1 ); } return; }; sub is_auto_write_for_type ($self, @args) { return 0 unless defined $self->backend_mgr; return $self->backend_mgr->is_auto_write_for_type(@args); } 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 ($self, @args) { my %args = _resolve_arg_shortcut(\@args, 'name'); my $name = $args{name}; my $type = $args{type}; my $autoadd = $args{autoadd} // 1; if ( not defined $name ) { Config::Model::Exception::Internal->throw( object => $self, info => "has_element: missing element name", ); } $self->accept_element($name) if $autoadd; 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 ($self, $elt_name) { return $self->{model}{element}{ $elt_name }; } sub element_type { my ($self, $name) = @_; croak "element_type: missing element name" unless $name; my $element_info = $self->{model}{element}{$name} // $self-> _get_accepted_data($name); Config::Model::Exception::UnknownElement->throw( object => $self, function => 'element_type', where => $self->location || 'configuration root', element => $name, ) unless defined $element_info; return $element_info->{type}; } sub get_element_name { goto &get_element_names; } sub get_element_names ($self, %args) { if (delete $args{for}) { carp "get_element_names 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} }; if ($args{all}) { my @res = grep { $self->{level}{$_} ne 'hidden' } @element_list; return wantarray ? @res : "@res"; } # 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} || get_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->trace("got @result"); return wantarray ? @result : join( ' ', @result ); } sub children { my $self = shift; return $self->get_element_names; } sub next_element ($self, %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 ($self, @args) { return $self->next_element( @args, reverse => 1 ); } sub get_element_property ($self, %args) { my ( $prop, $elt ) = $self->check_property_args( 'get_element_property', %args ); return $self->{$prop}{$elt} || get_default_property($prop); } sub set_element_property ($self, %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 ($self, %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 ($self, $method_name, %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 ($self, @args) { my %args = _resolve_arg_shortcut(\@args, 'name'); 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; my $autoadd = $args{autoadd} // 1; $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) if $autoadd; $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, ); } # do not warn when when is skip or "no" if ($self->{status}{$element_name} eq 'deprecated' and $check eq 'yes' ) { # FIXME elaborate more ? or include parameter description ?? my $msg = "Element '$element_name' of node '". $self->name. "' is deprecated"; if (not $self->was_element_warned($element_name)) { $user_logger->warn($msg); $self->warn_element_done($element_name,1); } # 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 ($self, @args) { my %args = @args > 1 ? @args : ( name => $args[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 ($self, @args) { my %args = _resolve_arg_shortcut(\@args, 'name', 'value'); return $self->fetch_element(%args)->store(%args); } sub is_element_available ($self, @args) { my ( $elt_name, $status ) = ( undef, 'deprecated' ); if ( @args == 1 ) { $elt_name = $args[0]; } else { my %args = @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 # retrieve element (and auto-vivify if needed) my $element = $self->fetch_element( name => $elt_name, # check => 'no' causes problem because elements below (when # loaded by another backend also below) are initialised with # check 'no'. Deprecated elements are loaded but changes are # not notified because of check/no. check => 'skip', 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}; my $acc = $self-> _get_accepted_data($name); return $self->reset_accepted_element_model( $name, $acc ) if $acc; return; } # return accepted model data or undef sub _get_accepted_data { my ( $self, $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); $user_logger->warn( "Warning: ".$self->location ." '$name' is confusingly close to '$best' (edit distance is $dist)." ." Is there a typo ?" ); } } return $self->{model}{accept}{$accept_regexp}; } 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 ($self, $elt_name) { return defined $self->{element}{ $elt_name }; } sub get ($self, @args) { my %args = _resolve_arg_shortcut(\@args, 'path'); 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->trace("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 ($self, $path, @args) { $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, @args ); } else { return $self->fetch_element($item)->set( $new_path, @args ); } } sub load ($self, @args) { my $loader = Config::Model::Loader->new( start_node => $self ); my %args = _resolve_arg_shortcut(\@args, 'steps'); if ( defined $args{step} || defined $args{steps}) { return $loader->load( %args ); } Config::Model::Exception::Load->throw( object => $self, message => "load called with no 'steps' parameter", ); return; } sub load_data ($self, @args) { my %args = _resolve_arg_shortcut(\@args, 'data'); 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( ' ', sort keys %$perl_data ) ); my $has_stored = 0; # 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) { $has_stored += $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->info("Node load_data: accepting element $elt"); $has_stored += $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, ); } return !! $has_stored; } sub dump_tree ($self, %args) { $self->init(); my $full = delete $args{full_dump} || 0; if ($full) { carp "dump_tree: full_dump parameter is deprecated. Please use 'mode => user' instead"; $args{mode} //= 'user'; } my $dumper = Config::Model::Dumper->new; return $dumper->dump_tree( node => $self, %args ); } sub migrate ($self, @args) { $self->init(); Config::Model::Dumper->new->dump_tree( node => $self, mode => 'full', @args ); return $self->needs_save; } sub dump_annotations_as_pod ($self, @args) { $self->init(); my $dumper = Config::Model::DumpAsData->new; return $dumper->dump_annotations_as_pod( node => $self, @args ); } sub describe ($self, @args) { $self->init(); my $descriptor = Config::Model::Describe->new; return $descriptor->describe( node => $self, @args ); } sub report ($self, @args) { $self->init(); my $reporter = Config::Model::Report->new; return $reporter->report( node => $self ); } sub audit ($self, @args) { $self->init(); my $reporter = Config::Model::Report->new; return $reporter->report( node => $self, audit => 1 ); } sub copy_from ($self, @args) { my %args = _resolve_arg_shortcut(\@args, 'from'); 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' ); return $self->load( step => $dump, check => $check ); } # TODO: need Pod::Text attribute -> move that to a role ? # to translate Pod description to plain text when help is displayed sub get_help ($self, $tag = '', $elt_name = ''){ if ($elt_name) { if ( $tag !~ /^(summary|description)$/ ) { croak "get_help: wrong argument $tag, expected ", "'description' or 'summary'"; } return $self->{$tag}{$elt_name} // ''; } if ($tag) { return $self->{description}{ $tag } // ''; } return $self->{model}{class_description} // ''; } sub get_info { my $self = shift; my @items = ( 'type: ' . $self->get_type, 'class name: ' . $self->config_class_name, ); my @rexp = $self->accept_regexp; if (@rexp) { push @items, 'accept: /^' . join( '$/, /^', @rexp ) . '$/'; } return @items; } sub tree_searcher ($self, @args){ return Config::Model::TreeSearcher->new( node => $self, @args ); } sub apply_fixes ($self, $filter='' ) { # define leaf call back my $do_apply = sub ($name) { return $filter ? $name =~ /$filter/ : 1; }; my $fix_leaf = sub { my ( $scanner, $data_ref, $node, $element_name, $index, $leaf_object ) = @_; $leaf_object->apply_fixes if $do_apply->($element_name); }; 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 $do_apply->($element); }; 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 $do_apply->($element); }; 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->trace("apply fix done"); return; } sub deep_check ($self, %args){ $deep_check_logger->trace("called on ".$self->name); # no deep_check defined (yet). Note that value check is done when # storing value (even during initial load, so there's no need to # force a check. my $check_leaf = sub { }; my $check_id = sub { my ( $scanner, $data_r, $node, $element, @keys ) = @_; $deep_check_logger->trace( "deep check called on from ", $node->name, " elt $element keys @keys" ); return unless @keys; $node->fetch_element($element)->deep_check; }; my $scan = Config::Model::ObjTreeScanner->new( hash_element_hook => $check_id, list_element_hook => $check_id, leaf_cb => $check_leaf, auto_vivify => $args{auto_vivify}, check => 'no', ); $deep_check_logger->debug( "deep check started from ", $self->name ); $scan->scan_node( undef, $self ); $deep_check_logger->trace("deep check done"); return; } __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.149 =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( steps => 'Y=Av' ); # add some accepted element, ipA and ipB are created on the fly $root->load( steps => 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 gets a set of rules that defines 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 is used while 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 String used to construct a summary of the content of a node. This parameter is used by user interface to show users the gist of the content of this node. This parameter has no other effect. This string may contain element values in the form "C<{foo} or {bar}>". When constructing the gist, C<{foo}> is replaced by the value of element C. Likewise for C<{bar}>. =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 are shown to the user no matter what. C elements are 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 issues a warning. Using an obsolete element raises an exception (See L. status => [ [qw/X Y/] => 'obsolete' ] =item B Optional C of element summaries. These summaries may be used when generating user interfaces. =item B Optional C of element descriptions. These descriptions may be used when generating user interfaces. =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 has a list of specification that 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 is issued if an accepted element is too close to an existing element. The parameter C to specify where to insert the accepted element. This does not change much the behavior of the tree, but helps generate a more usable user interface. Example: element => [ 'Bug' => { type => 'leaf', value_type => 'uniline' } , ] accept => [ 'Bug-.*' => { value_type => 'uniline', type => 'leaf' accept_after => 'Bug' , } ] The model snippet above ensures that C is shown right after C. =for html =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 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 Arguments: C<< ( name => element_name, [ type => searched_type ], [ autoadd => 1 ] ) >> Returns 1 if the class model has the element declared. Returns 1 as well if C is 1 (i.e. by default) and the element name is matched by the optional C model parameter. If C is specified, the element name must also match the type. =head2 find_element Parameters: C<< ( element_name , [ case => any ]) >> Returns C<$name> if the class model has the element declared or if the element name is matched by the optional C parameter. If C is set to any, C returns 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. 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 Parameters: C<< ( element_name ) >> Returns model of the element. =head2 element_type Parameters: C<< ( element_name ) >> Returns the type (e.g. leaf, hash, list, checklist or node) of the element. Also returns the type of a potentially accepted element. Dies if the element is not known or cannot be accepted. =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_names Return all available element names, including the element that were accepted. Optional parameters are: =over =item * B: Boolean. When set return all element names, even the hidden ones and does not trigger warp mechanism. Defaults to 0. This option should be set to 1 when this method is needed to read configuration data from a backend. =item * B: Returns only element of requested type (e.g. C, C, C,...). By default return elements of any type. =item * B: Returns only hash or list elements that contain the requested cargo type. E.g. if C is called with C<< cargo_type => 'leaf' >>, then C returns hash or list elements that contain a L object. =item * B: C, C or C =back C and C parameters can be specified together. In this case, this method returns parameters that satisfy B conditions. I.e. with C<< type =>'hash', cargo_type => 'leaf' >>, this method returns only hash elements that contain leaf objects. Returns a list in array context, and a string (e.g. C) in scalar context. =head2 children Like C 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 Parameters: C<< ( 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 Parameters: C<< ( element => ..., property => ... ) >> Retrieve a property of an element. I.e. for a model : status => [ X => 'deprecated' ] element => [ X => { ... } ] This call returns C: $node->get_element_property ( element => 'X', property => 'status' ) =head2 set_element_property Parameters: C<< ( element => ..., property => ... ) >> Set a property of an element. =head2 reset_element_property Parameters: C<< ( element => ... ) >> Reset a property of an element according to the original model. =head1 Information management =head2 fetch_element Arguments: C<< ( name => .. , [ check => ..], [ autoadd => 1 ] ) >> Fetch and returns an element from a node if the class model has the element declared. Also fetch and returns an element from a node if C is 1 (i.e. by default) and the element name is matched by the optional C model parameter. C can be set to C, C or C. When C is C or C, this method returns C when the element is unknown, or 0 if the element is not available (hidden). By default, "accepted" elements are automatically created. Set C to 0 when this behavior is not wanted. =head2 fetch_element_value Parameters: C<< ( name => ... [ check => ...] ) >> Fetch and returns the I of a leaf element from a node. =head2 fetch_gist Return the gist of the node. See description of C parameter above. =head2 store_element_value Parameters: C<< ( name, value ) >> Store a I in a leaf element from a node. Can be invoked with named parameters (name, value, check). E.g. ( name => 'foo', value => 'bar', check => 'skip' ) =head2 is_element_available Parameters: C<< ( 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 Parameters: C<< ( name ) >> Checks and returns the appropriate model of an acceptable element (i.e. declared as a model C or part of an C declaration). Returns undef if the element cannot be accepted. =head2 accept_regexp Parameters: C<< ( name ) >> Returns the list of regular expressions used to check for acceptable parameters. Useful for diagnostics. =head2 element_exists Parameters: C<< ( element_name ) >> Returns 1 if the element is known in the model. =head2 is_element_defined Parameters: C<< ( 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 Parameters: C<< ( path => ..., mode => ... , check => ... , get_obj => 1|0, autoadd => 1|0) >> Get a value from a directory like path. If C is 1, C returns a leaf object instead of returning its value. =head2 set Parameters: C<< ( path , value) >> Set a value from a directory like path. =head1 Validation =head2 deep_check Scan the tree and deep check on all elements that support this. Currently only hash or list element have this feature. =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 Parameters: C<< ( steps => 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 Parameters: C<< ( 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 are discarded. C can be called with a single hash ref parameter. Returns 1 if some data were saved (instead of skipped). =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 Parameters: C<< ( [ 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 shows only value different from their default value. =head2 copy_from Parameters: C<< ( 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 Parameters: C<< ( [ [ 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 get_info Returns a list of information related to the node. See L for more details. =head2 tree_searcher Parameters: C<< ( 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 Then, C method must then be called on the object returned by C. 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-2022 by Dominique Dumont. This is free software, licensed under: The GNU Lesser General Public License, Version 2.1, February 1999 =cut Config-Model-2.149/lib/Config/Model/Instance.pm0000644000175000017500000006635514170053137017573 0ustar domidomi# # This file is part of Config-Model # # This software is Copyright (c) 2005-2022 by Dominique Dumont. # # This is free software, licensed under: # # The GNU Lesser General Public License, Version 2.1, February 1999 # package Config::Model::Instance 2.149; #use Scalar::Util qw(weaken) ; use strict; use 5.10.1; use Mouse; use Mouse::Util::TypeConstraints; use MouseX::StrictConstructor; with "Config::Model::Role::NodeLoader"; use File::Path; use Path::Tiny; use Log::Log4perl qw(get_logger :levels); use Config::Model::TypeConstraints; use Config::Model::Exception; use Config::Model::Node; use Config::Model::Loader; use Config::Model::SearchElement; use Config::Model::Iterator; use Config::Model::ObjTreeScanner; use warnings ; use Carp qw/carp croak confess cluck/; my $logger = get_logger("Instance"); my $change_logger = get_logger("Anything::Change"); my $user_logger = get_logger("User"); has [qw/root_class_name/] => ( is => 'ro', isa => 'Str', required => 1 ); sub location { return "in instance" } has config_model => ( is => 'ro', isa => 'Config::Model', weak_ref => 1, required => 1 ); has check => ( is => 'ro', isa => 'Str', default => 'yes', reader => 'read_check', ); # used by cme -create option has auto_create => ( is => 'ro', isa => 'Bool', default => 0, ); # a unique (instance wise) placeholder for various tree objects # to store information has _safe => ( is => 'rw', isa => 'HashRef', traits => ['Hash'], default => sub { {} }, handles => { data => 'accessor', }, ); has appli_info => ( is => 'rw', isa => 'HashRef', traits => ['Hash'], default => sub { {} }, handles => { get_appli_info => 'get', # currying See Moose::Manual::Delegation get_support_info => [qw/get support_info/], }, ); # preset mode: to load values found by HW scan or other automatic scheme # layered mode: to load values found in included files (e.g. a la multistrap) # canonical mode: write config data back using model order instead of user order has [qw/preset layered canonical/] => ( is => 'ro', isa => 'Bool', default => 0, ); has changes => ( is => 'ro', isa => 'ArrayRef', traits => ['Array'], default => sub { [] }, handles => { add_change => 'push', c_count => 'count', has_changes => 'count', #needs_save => 'count' , clear_changes => 'clear', } ); sub needs_save { my $self = shift; my $arg = shift; if ( defined $arg ) { if ($arg) { croak "replace needs_save(1) call with add_change"; $self->add_change(); # may not work } else { croak "replace needs_save(0) call with clear_changes"; $self->clear_changes; } } return $self->c_count; } has errors => ( is => 'ro', isa => 'HashRef', traits => ['Hash'], default => sub { {} }, handles => { _set_error => 'set', cancel_error => 'delete', has_error => 'count', clear_errors => 'clear', error_paths => 'keys' } ); sub add_error { my $self = shift; $self->_set_error( shift, '' ); } sub error_messages { my $self = shift; my @errs = map { "$_: " . $self->config_root->grab($_)->error_msg } $self->error_paths; return wantarray ? @errs : join( "\n", @errs ); } sub has_warning { my $self = shift; my $count_leaf_warnings = sub { my ( $scanner, $data_ref, $node, $element_name, $index, $leaf_object ) = @_; $$data_ref += $leaf_object->has_warning; }; my $count_list_warnings = sub { my ( $scanner, $data_ref, $node, $element_name, $index, $leaf_object ) = @_; $$data_ref += $node->fetch_element($element_name)->has_warning; }; my $scan = Config::Model::ObjTreeScanner->new( leaf_cb => $count_leaf_warnings, list_element_hook => $count_list_warnings, hash_element_hook => $count_list_warnings, ); my $result = 0; $scan->scan_node( \$result, $self->config_root ); return $result; } has on_change_cb => ( is => 'rw', traits => ['Code'], isa => 'CodeRef', default => sub { sub { } }, ); has on_message_cb => ( traits => ['Code'], is => 'rw', isa => 'CodeRef', default => sub { sub { say @_; } }, handles => { show_message => 'execute', }, ); # initial_load mode: when data is loaded the first time has initial_load => ( is => 'rw', isa => 'Bool', default => 0, trigger => \&_trace_initial_load, traits => [qw/Bool/], handles => { initial_load_start => 'set', initial_load_stop => 'unset', } ); sub _trace_initial_load { my ( $self, $n, $o ) = @_; $logger->debug("switched to $n"); } # This array holds a set of sub ref that will be invoked when # the user requires to write all configuration tree in their # backend storage. has _write_back => ( is => 'ro', isa => 'HashRef', traits => ['Hash'], handles => { count_write_back => 'count', # mostly for tests has_no_write_back => 'is_empty', nodes_to_write_back => 'keys', write_back_node_info => 'get', delete_write_back => 'delete', clear_write_back => 'clear', }, default => sub { {} }, ); sub register_write_back { my ($self, $path, $backend, $wb) = @_; push @{ $self->_write_back->{$path} //= [] }, [$backend, $wb]; } # used for auto_read auto_write feature has [qw/name application backend backend_arg backup/] => ( is => 'ro', isa => 'Maybe[Str]', ); has 'root_dir' => ( is => 'ro', isa => 'Config::Model::TypeContraints::Path', coerce => 1 ); has root_path => ( is => 'ro', isa => 'Path::Tiny', lazy_build => 1, ); sub _build_root_path { my $self = shift; my $root_dir = $self->root_dir // ''; return $root_dir ? path($root_dir) : Path::Tiny->cwd; } has [qw/config_dir config_file/] => ( is => 'ro', isa => 'Config::Model::TypeContraints::Path', coerce => 1 ); has tree => ( is => 'ro', isa => 'Config::Model::Node', builder => '_build_tree', lazy => 1, clearer => '_clear_config', reader => 'config_root', handles => [qw/apply_fixes deep_check grab grab_value/], ); sub reset_config { my $self = shift; $self->_clear_config; $self->clear_changes; return $self->config_root; } sub _build_tree { my $self = shift; return $self->load_node ( config_class_name => $self->{root_class_name}, instance => $self, container => $self, config_file => $self->{config_file}, ); } sub preset_start { my $self = shift; $logger->info("Starting preset mode"); carp "Cannot start preset mode during layered mode" if $self->{layered}; $self->{preset} = 1; } sub preset_stop { my $self = shift; $logger->info("Stopping preset mode"); $self->{preset} = 0; } sub preset_clear { my $self = shift; my $leaf_cb = sub { my ( $scanner, $data_ref, $node, $element_name, $index, $leaf_object ) = @_; $$data_ref ||= $leaf_object->clear_preset; }; $self->_stuff_clear($leaf_cb); } sub layered_start { my $self = shift; $logger->info("Starting layered mode"); carp "Cannot start layered mode during preset mode" if $self->{preset}; $self->{layered} = 1; } sub layered_stop { my $self = shift; $logger->info("Stopping layered mode"); $self->{layered} = 0; } sub layered_clear { my $self = shift; my $leaf_cb = sub { my ( $scanner, $data_ref, $node, $element_name, $index, $leaf_object ) = @_; $$data_ref ||= $leaf_object->clear_layered; }; $self->_stuff_clear($leaf_cb); } sub get_data_mode { my $self = shift; return $self->{layered} ? 'layered' : $self->{preset} ? 'preset' : 'normal'; } sub _stuff_clear { my ( $self, $leaf_cb ) = @_; # this sub may remove hash keys that were entered by user if the # corresponding hash value has no data. # it also clear auto_created ids if there's no data in there my $h_cb = sub { my ( $scanner, $data_ref, $node, $element_name, @keys ) = @_; my $obj = $node->fetch_element($element_name); # Since remove method uses splice(array) on list elements, the # removal must be done in reverse order to avoid messing up # the indexes of the array (i.e. the last indexes becomes # greater than the length of the array). foreach my $k (reverse @keys) { my $has_data = 0; $scanner->scan_hash( \$has_data, $node, $element_name, $k ); $obj->remove($k) unless $has_data; $$data_ref ||= $has_data; } }; my $wiper = Config::Model::ObjTreeScanner->new( fallback => 'all', auto_vivify => 0, check => 'skip', leaf_cb => $leaf_cb, hash_element_cb => $h_cb, list_element_cb => $h_cb, ); $wiper->scan_node( undef, $self->config_root ); } sub modify { my $self = shift ; my %args = @_ eq 1 ? ( step => $_[0] ) : @_; my $force = delete $args{force_save} || delete $args{force}; my $quiet = delete $args{quiet}; $self->load(%args); $self->say_changes() unless $quiet; $self->write_back( force => $force ); return $self; } sub load { my $self = shift; my $loader = Config::Model::Loader->new( start_node => $self->config_root ); my %args = @_ eq 1 ? ( step => $_[0] ) : @_; $loader->load( %args ); return $self; } sub search_element { my $self = shift; $self->config_root->search_element(@_); } sub wizard_helper { carp __PACKAGE__, "::wizard_helper helped is deprecated. Call iterator instead"; goto &iterator; } sub iterator { my $self = shift; my @args = @_; my $tree_root = $self->config_root; return Config::Model::Iterator->new( root => $tree_root, @args ); } sub read_directory { carp "read_directory is deprecated"; return shift->root_dir; } sub write_directory { my $self = shift; carp "write_directory is deprecated"; return $self->root_dir; } sub write_root_dir { my $self = shift; carp "deprecated"; return $self->root_dir; } # FIXME: record changes to implement undo/redo ? sub notify_change { my $self = shift; my %args = @_; if ( $change_logger->is_debug ) { $change_logger->debug( "in instance ", $self->name, ' for path ', $args{path} ); } foreach my $obsolete (qw/note_only msg/) { if ( my $m = delete $args{$obsolete} ) { carp "notify_change: param $obsolete is obsolete ($m)"; $args{note} //=''; $args{note} .= $m; } } $self->add_change( \%args ); $self->on_change_cb->( %args ); } sub _truncate { my @lines = @_; foreach my $l (@lines) { next unless defined $l; $l =~ s/\n/ /g; substr ($l, 60) = '[...]' if length $l > 60; # limit string length } return @lines; } sub list_changes { my $self = shift; my $l = $self->changes; my @all; foreach my $c (@$l) { my $path = $c->{path} ; my $vt = $c->{value_type} || ''; my ( $o, $n ) = _truncate( $c->{old}, $c->{new} ); my $note = $c->{note} ? " # $c->{note}" : ''; if ( defined $n and not defined $o ) { push @all, "$path has new value: '$n'$note"; } elsif ( not defined $n and defined $o) { push @all, "$path deleted value: '$o'$note"; } elsif ( defined $o and defined $n ) { push @all, "$path: '$o' -> '$n'$note"; } elsif ( defined $c->{note} ) { push @all, "$path: ".$c->{note}; } else { # something's unexpected with the call to notify_change push @all, "changed ".join(' ', each %$c); } } return wantarray ? @all : join( "\n", @all ); } sub say_changes { my $self = shift; my @changes = $self->list_changes; return $self unless @changes; my $msg = "\n" . join( "\n- ", "Changes applied to " . ($self->application // $self->name) . " configuration:", @changes ) . "\n"; $user_logger->info($msg); return $self; } sub write_back { my $self = shift; my %args = scalar @_ > 1 ? @_ : scalar @_ == 1 ? ( config_dir => $_[0] ) : (); my $force_write = delete $args{force} || 0; if (delete $args{root}) { say "write_back: root argument is no longer supported"; } # make sure that root node is loaded $self->config_root->init; if ($force_write) { # make sure that the whole tree is loaded my $dump = $self->config_root->dump_tree; } foreach my $k ( keys %args ) { if ($k eq 'config_dir') { $args{$k} ||= ''; $args{$k} .= '/' if $args{$k} and $args{$k} !~ m(/$); } elsif ( $k !~ /^(config_file|backend)$/ ) { croak "write_back: wrong parameters $k"; } } if ($self->has_no_write_back ) { my $info = $self->application ? "the model of application ".$self->application : "model ".$self->root_class_name ; croak "Don't know how to save data of $self->{name} instance. ", "Either $info has no configured ", "read/write backend or no node containing a backend was loaded. ", "Try with -force option or add read/write backend to $info\n"; } foreach my $path ( sort $self->nodes_to_write_back ) { $logger->info("write_back called on node $path"); if ( $path and $self->{config_file} ) { $logger->warn("write_back: cannot override config_file in non root node ($path)"); delete $self->{config_file} } $self->_write_back_node(%args, path => $path, force_write => $force_write) ; } $self->clear_changes; } sub _write_back_node { my $self = shift; my %args = @_; my $path = delete $args{path}; my $force_backend = delete $args{backend} || $self->{backend}; my $force_write = delete $args{force_write}; my $node = $self->config_root->grab( step => $path, type => 'node', mode => 'loose', autoadd => 0, ); foreach my $wb_info (@{ $self->write_back_node_info($path) }) { my ($backend, $cb) = @$wb_info; my @wb_args = ( %args, config_file => $self->{config_file}, force_backend => $force_backend, force => $force_write, backup => $self->backup, ); if (defined $node and ($node->needs_save or $force_write)) { my $dir = $args{config_dir}; mkpath( $dir, 0, oct(755) ) if $dir and not -d $dir; my $res ; if (not $force_backend or $force_backend eq $backend or $force_backend eq 'all' ) { # exit when write is successfull my $res = $cb->(@wb_args); $logger->info( "write_back called with $backend backend, result is ", defined $res ? $res : '' ); last if ( $res and not $force_backend ); } } if (not defined $node) { $logger->debug("deleting file for deleted node $path"); $cb->(@wb_args, force_delete => 1); $self->delete_write_back($path); } } $logger->trace( "write_back on node '$path' done" ); } sub save { goto &write_back; } sub update { my ($self, %args) = @_; my @msgs ; my $hook = sub { my ($scanner, $data_ref,$node,@element_list) = @_; if ($node->can('update')) { my $loc = $node->location; say "Calling update on node '$loc'" if $loc and not $args{quiet}; push (@msgs, $node->update(%args)) } ; }; my $root = $self->config_root ; Config::Model::ObjTreeScanner->new( node_content_hook => $hook, check => ($args{quiet} ? 'no' : 'yes'), leaf_cb => sub { } )->scan_node( \@msgs, $root ); return @msgs; } sub DEMOLISH { my $self = shift; $self->clear_write_back; # avoid reference loops } __PACKAGE__->meta->make_immutable; 1; # ABSTRACT: Instance of configuration tree __END__ =pod =encoding UTF-8 =head1 NAME Config::Model::Instance - Instance of configuration tree =head1 VERSION version 2.149 =head1 SYNOPSIS use Config::Model; use File::Path ; # setup a dummy popcon conf file my $wr_dir = '/tmp/etc/'; my $conf_file = "$wr_dir/popularity-contest.conf" ; unless (-d $wr_dir) { mkpath($wr_dir, { mode => 0755 }) || die "can't mkpath $wr_dir: $!"; } open(my $conf,"> $conf_file" ) || die "can't open $conf_file: $!"; $conf->print( qq!MY_HOSTID="aaaaaaaaaaaaaaaaaaaa"\n!, qq!PARTICIPATE="yes"\n!, qq!USEHTTP="yes" # always http\n!, qq!DAY="6"\n!); $conf->close ; my $model = Config::Model->new; # PopCon model is provided. Create a new Config::Model::Instance object my $inst = $model->instance (root_class_name => 'PopCon', root_dir => '/tmp', ); my $root = $inst -> config_root ; print $root->describe; =head1 DESCRIPTION This module provides an object that holds a configuration tree. =head1 CONSTRUCTOR An instance object is created by calling L on an existing model. This model can be specified by its application name: my $inst = $model->instance ( # run 'cme list' to get list of applications application => 'foo', # optional instance_name => 'test1' ); my $inst = $model->instance ( root_class_name => 'SomeRootClass', instance_name => 'test1' ); The directory (or directories) holding configuration files is specified within the configuration model. For test purpose you can change the "root" directory with C parameter. Constructor parameters are: =over =item root_dir Pseudo root directory where to read I write configuration files (L object or string). Configuration directory specified in model or with C option is appended to this root directory =item root_path L object created with C value or with current directory if C is empty. =item config_dir Directory to read or write configuration file. This parameter must be supplied if not provided by the configuration model. (string) =item backend Specify which backend to use. See L for details =item backend_arg Specify a backend argument that may be retrieved by some backend. Instance is used as a relay and does not use this data. =item check Specify whether to check value while reading config files. Either: =over =item yes Check value and throws an error for bad values. =item skip Check value and skip bad value. =item no Do not check. =back =item canonical When true: write config data back using model order. By default, write items back using the order found in the configuration file. This feature is experimental and not supported by all backends. =item on_change_cb Call back this function whenever C is called. Called with arguments: C<< name => , index => >> =item on_message_cb Call back this function when L is called. By default, messages are displayed on STDOUT. =item error_paths Returns a list of tree items that currently have an error. =item error_messages Returns a list of error messages from the tree content. =back Note that the root directory specified within the configuration model is overridden by C parameter. If you need to load configuration data that are not correct, you can use C<< force_load => 1 >>. Then, wrong data are discarded (equivalent to C<< check => 'no' >> ). =head1 METHODS =head2 Manage configuration data =head2 modify Calls L and then L. Takes the same parameter as C plus: =over =item C Force saving configuration file even if no value was modified (default is 0) =item C Do no display the changes brought by the modification steps =back =head2 load Load configuration tree with configuration data. See L for parameters. Returns <$self>. =head2 save Save the content of the configuration tree to configuration files. (See L for more details) Use C<< force => 1 >> option to force saving configuration data. =head2 config_root Returns the L of the configuration tree. =head2 apply_fixes Scan the tree and apply fixes that are attached to warning specifications. See C or C in L. =head2 deep_check Scan the tree and deep check on all elements that support this. Currently only hash or list element have this feature. =head2 needs_save Returns 1 (or more) if the instance contains data that needs to be saved. I.e some change were done in the tree that needs to be saved. =head2 has_changes Returns true if the instance contains unsasved changes. =head2 list_changes In list context, returns a array ref of strings describing the changes. In scalar context, returns a big string. Useful to print. =head2 say_changes Print all changes on STDOUT and return C<$self>. =head2 clear_changes Clear list of changes. Note that changes pending in the configuration tree is not affected. This clears only the list shown to user. Use only for tests. =head2 has_warning Returns the number of warning found in the elements of this configuration instance. =head2 update Parameters: C<< ( quiet => (0|1), %args ) >> Try to run update command on all nodes of the configuration tree. Node without C method are ignored. C prints a message otherwise (unless C is true). =head2 grab Use the steps parameter to retrieve and returns an object from the configuration tree. Forwarded to L =head2 grab_value Use the steps parameter to retrieve and returns the value of a leaf object from the configuration tree. Forwarded to L =head2 searcher Returns an object dedicated to search an element in the configuration model. This method returns a L object. See L for details on how to handle a search. =head2 iterator This method returns a L object. See L for details. Arguments are explained in L L. =head2 application Returns the application name of the instance. (E.g C, C ...) =head2 wizard_helper Deprecated. Call L instead. =head1 Internal methods =head2 name Returns the instance name. =head2 read_check Returns which kind of check is performed while reading configuration files. (see C parameter in L section) =head2 show_message Parameters: C<( string )> Display the message on STDOUT unless a custom function was passed to C parameter. =head2 reset_config Destroy current configuration tree (with data) and returns a new tree with data (and annotations) loaded from disk. =head2 config_model Returns the model (L object) of the configuration tree. =head2 annotation_saver Returns the object loading and saving annotations. See L for details. =head2 preset_start All values stored in preset mode are shown to the user as default values. This feature is useful to enter configuration data entered by an automatic process (like hardware scan) =head2 preset_stop Stop preset mode =head2 preset Get preset mode =head2 preset_clear Clear all preset values stored. =head2 layered_start All values stored in layered mode are shown to the user as default values. This feature is useful to enter configuration data entered by an automatic process (like hardware scan) =head2 layered_stop Stop layered mode =head2 layered Get layered mode =head2 layered_clear Clear all layered values stored. =head2 get_data_mode Returns 'normal' or 'preset' or 'layered'. Does not take into account initial_load. =head2 initial_load_start Start initial_load mode. This mode tracks the first modifications of the tree done with data read from the configuration file. Instance is built with initial_load as 1. Read backend clears this value once the first read is done. Other modifications, when initial_load is zero, are assumed to be user modifications. =head2 initial_load_stop Stop initial_load mode. Instance is built with initial_load as 1. Read backend clears this value once the first read is done. =head2 initial_load Get initial_load mode =head2 data This method provides a way to store some arbitrary data in the instance object. E.g: $instance->data(foo => 'bar'); Later: my $foo = $instance->data('foo'); # $foo contains 'bar' =head1 Read and write backend features Usually, a program based on config model must first create the configuration model, then load all configuration data. This feature enables you to declare with the model a way to load configuration data (and to write it back). See L for details. =head2 backend Get the preferred backend method for this instance (as passed to the constructor). =head2 backend_arg Get L command line argument that may be used by the backend to get the configuration file. These method is typically used in the read and write method of a backend to know where is the configuration file to edit. =head2 root_dir Returns a L object for the root directory where configuration data is read from or written to. =head2 root_path Same as C =head2 register_write_back Parameters: C<( node_location )> Register a node path that is called back with C method. =head2 notify_change Notify that some data has changed in the tree. See L for more details. =head2 write_back In summary, save the content of the configuration tree to configuration files. In more details, C trie to run all subroutines registered with C to write the configuration information. (See L for details). You can specify here another config directory to write configuration data back with C parameter. This overrides the model specifications. C croaks if no write call-back are known. Use C<< force => 1 >> option to force saving configuration data. This is useful to write back a file even no change are done at semantic level, i.e. to reformat a file or remove unnecessary data. =head1 AUTHOR Dominique Dumont, (ddumont at cpan dot org) =head1 SEE ALSO L, L, L, L, L, =head1 AUTHOR Dominique Dumont =head1 COPYRIGHT AND LICENSE This software is Copyright (c) 2005-2022 by Dominique Dumont. This is free software, licensed under: The GNU Lesser General Public License, Version 2.1, February 1999 =cut Config-Model-2.149/lib/Config/Model/system.d/0000755000175000017500000000000014170053137017220 5ustar domidomiConfig-Model-2.149/lib/Config/Model/system.d/fstab0000644000175000017500000000001614170053137020237 0ustar domidomimodel = Fstab Config-Model-2.149/lib/Config/Model/system.d/popcon0000644000175000017500000000001714170053137020437 0ustar domidomimodel = PopCon Config-Model-2.149/lib/Config/Model/log4perl.conf0000644000175000017500000000255014170053137020053 0ustar domidomilog4perl.rootLogger=WARN, Screen # user message about deprecation issues log4perl.logger.Model.Legacy = INFO, SimpleScreen log4perl.additivity.Model.Legacy = 0 # show messages for users at INFO or above levels log4perl.logger.User = INFO, PlainMsgOnScreen # uncomment lower levels if needed #log4perl.logger.User = DEBUG, PlainMsgOnScreen #log4perl.logger.User = TRACE, PlainMsgOnScreen log4perl.additivity.User = 0 # Verbose messsages for user when loading data log4perl.logger.Verbose.Loader = WARN, PlainMsgOnScreen log4perl.additivity.Verbose.Loader = 0 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 = %M %m (line %L)%n log4perl.appender.SimpleScreen = Log::Log4perl::Appender::Screen log4perl.appender.SimpleScreen.stderr = 1 log4perl.appender.SimpleScreen.layout = Log::Log4perl::Layout::PatternLayout log4perl.appender.SimpleScreen.layout.ConversionPattern = %p: %m%n log4perl.appender.PlainMsgOnScreen = Log::Log4perl::Appender::ScreenColoredLevels log4perl.appender.PlainMsgOnScreen.stderr = 1 log4perl.appender.PlainMsgOnScreen.layout = Log::Log4perl::Layout::PatternLayout log4perl.appender.PlainMsgOnScreen.layout.ConversionPattern = %m%n log4perl.oneMessagePerAppender = 1 Config-Model-2.149/lib/Config/Model/Utils/0000755000175000017500000000000014170053137016552 5ustar domidomiConfig-Model-2.149/lib/Config/Model/Utils/GenClassPod.pm0000644000175000017500000000436714170053137021264 0ustar domidomi# # This file is part of Config-Model # # This software is Copyright (c) 2005-2022 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 2.149; # 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 Path::Tiny ; use Config::Model ; # to generate doc sub gen_class_pod { # make sure that doc is generated from models from ./lib and not # installed models my $local_model_dir = path("lib/Config/Model/models") -> absolute; my $cm = Config::Model -> new(model_dir => $local_model_dir->stringify ) ; my %done; my @models = @_ ? @_ : map { /^\s*model\s*=\s*([\w:-]+)/ ? ($1) : (); } map { $_->lines; } map { $_->children; } path ("lib/Config/Model/")->children(qr/\.d$/); foreach my $model (@models) { # %done avoid generating doc several times (generate_doc scan docs for # classes referenced by the model with config_class_name parameter) print "Checking doc for model $model\n"; $cm->load($model) ; $cm->generate_doc ($model,'lib', \%done) ; } } 1; __END__ =pod =encoding UTF-8 =head1 NAME Config::Model::Utils::GenClassPod - generate pod documentation from configuration models =head1 VERSION version 2.149 =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 scans 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 writes 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-2022 by Dominique Dumont. This is free software, licensed under: The GNU Lesser General Public License, Version 2.1, February 1999 =cut Config-Model-2.149/lib/Config/Model/TermUI.pm0000644000175000017500000002764214170053137017170 0ustar domidomi# # This file is part of Config-Model # # This software is Copyright (c) 2005-2022 by Dominique Dumont. # # This is free software, licensed under: # # The GNU Lesser General Public License, Version 2.1, February 1999 # package Config::Model::TermUI 2.149; use Carp; use utf8; # so literals and identifiers can be in UTF-8 use v5.12; # or later to get "unicode_strings" feature use strict; use warnings; use open qw(:std :utf8); # undeclared streams in UTF-8 use Encode qw(decode_utf8); 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; }; my $fix_completion_sub = sub { my ( $self, $text, $line, $start ) = @_; my @choice = $self->{current_node}->get_element_name; push @choice, '!'; my @ret = grep { /^$text/ } @choice ; return @ret; }; my $ll_completion_sub = sub { my ( $self, $text, $line, $start ) = @_; my @choice = $self->{current_node}->get_element_name; push @choice, '-nz'; my @ret = grep { /^$text/ } @choice ; return @ret; }; # BUG: autocompletion does not really work on a hash element with an index # containing white space (i.e. something like std_id:"abc def", my $cd_completion_sub = sub { my ( $self, $text, $line, $start ) = @_; # 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 ; return @ret; }; my $path_completion_sub = sub { my ( $self, $text, $line, $start, $node_only ) = @_; # we know that text begins with a command my $cmd = $line; $cmd =~ s/^\w+\s+//; 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; my $new_type = $new_item->get_type; my @children = $node_only ? $new_item->get_element_name( cargo_type => 'node' ) : $new_item->get_element_name(); # say "Children: @children"; foreach my $elt_name (@children) { if ( $new_item->element_type($elt_name) =~ /^(hash|list)$/ ) { push @choice, "$elt_name:" unless $node_only; 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 ; return @ret; }; # like path completion, but allow only completion on a node my $node_completion_sub = sub { return $path_completion_sub->(@_, 1); }; my %completion_dispatch = ( cd => $cd_completion_sub, desc => $completion_sub, display => $completion_sub, ll => $ll_completion_sub, ls => $path_completion_sub, tree => $node_completion_sub, info => $path_completion_sub, check => $completion_sub, fix => $fix_completion_sub, clear => $completion_sub, set => $leaf_completion_sub, delete => $leaf_completion_sub, reset => $completion_sub, ); sub completion { my ( $self, $text, $line, $start ) = @_; 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; # say "Input: ['$text', '$line', $start], "; my @choices = $completion_dispatch{$main}->( $self, $text, $line, $start ); # say "Choices: ['", join("', '",@choices),"']"; return @choices; } 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 "TermUI->new: Missing $p parameter"; } $self->{current_node} = $self->{root}; my $term = Term::ReadLine->new( $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; # this method is available only on Term::ReadLine::Gnu > 1.32 $term->enableUTF8 if $term->can('enableUTF8'); } elsif ( $term->ReadLine eq "Term::ReadLine::Perl" ) { no warnings "once"; warn "utf-8 support has not beed tested with Term::ReadLine::Perl. ", "You should install Term::ReadLine::Gnu.\n"; $readline::rl_completion_function = $sub_ref; &readline::rl_set( rl_completer_word_break_characters => $word_break_string ); # &readline::rl_set('TcshCompleteMode', 'On'); } else { warn "You should install Term::ReadLine::Gnu for autocompletion and utf-8 support.\n"; } $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'; $user_cmd = decode_utf8($user_cmd,1); #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 ) { if ($instance->has_changes) { $instance->say_changes; $user_cmd = $term->readline("write back data before exit ? (Y/n)"); $instance->write_back unless $user_cmd =~ /n/i; print "\n"; } } } 1; # ABSTRACT: Interactive command line interface for cme __END__ =pod =encoding UTF-8 =head1 NAME Config::Model::TermUI - Interactive command line interface for cme =head1 VERSION version 2.149 =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 $steps = 'foo=FOO hash_of_nodes:fr foo=bonjour - hash_of_nodes:en foo=hello '; $root->load( steps => $steps ); 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 dumps 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 is used. See L to override default choice. =head1 Dependencies This module is optional and depends on L to work. To reduce the dependency list of L, C is only recommended. L gracefully degrades to L when necessary. =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-2022 by Dominique Dumont. This is free software, licensed under: The GNU Lesser General Public License, Version 2.1, February 1999 =cut Config-Model-2.149/lib/Config/Model/IdElementReference.pm0000644000175000017500000002517614170053137021510 0ustar domidomi# # This file is part of Config-Model # # This software is Copyright (c) 2005-2022 by Dominique Dumont. # # This is free software, licensed under: # # The GNU Lesser General Public License, Version 2.1, February 1999 # package Config::Model::IdElementReference 2.149; use Mouse; use Carp; use Config::Model::ValueComputer; use Log::Log4perl qw(get_logger :levels); my $logger = get_logger("Tree::Element::IdElementReference"); # config_elt is a reference to the object that called new has config_elt => ( is => 'ro', isa => 'Config::Model::AnyThing', required => 1, weak_ref => 1 ); has refer_to => ( is => 'ro', isa => 'Maybe[Str]' ); has computed_refer_to => ( is => 'ro', isa => 'Maybe[HashRef]' ); sub BUILD { my $self = shift; my $found = scalar grep { defined $self->$_; } qw/refer_to computed_refer_to/; if ( not $found ) { Config::Model::Exception::Model->throw( object => $self->config_elt, message => "missing " . "refer_to or computed_refer_to parameter" ); } elsif ( $found > 1 ) { Config::Model::Exception::Model->throw( object => $self->config_elt, message => "cannot specify both " . "refer_to and computed_refer_to parameters" ); } my $rft = $self->{refer_to}; my $crft = $self->{computed_refer_to} || {}; my %c_args = %$crft; my $refer_path = defined $rft ? $rft : delete $c_args{formula}; # split refer_path on + then create as many ValueComputer as # required my @references = split /\s+\+\s+/, $refer_path; foreach my $single_path (@references) { push @{ $self->{compute} }, Config::Model::ValueComputer->new( formula => $single_path, variables => {}, %c_args, value_object => $self->{config_elt}, value_type => 'string' # a reference is always a string ); } return $self; } # internal # FIXME: do not call back value object -> may recurse sub get_choice_from_referred_to { my $self = shift; my $config_elt = $self->{config_elt}; my @enum_choice = $config_elt->get_default_choice; foreach my $compute_obj ( @{ $self->{compute} } ) { my $user_spec = $compute_obj->compute; next unless defined $user_spec; my @path = split( /\s+/, $user_spec ); $logger->trace("path: @path"); my $referred_to = eval { $config_elt->grab("@path"); }; if (ref $@) { my $e = $@; # don't use $e->full_description as it will recurse badly Config::Model::Exception::Model->throw( object => $config_elt, error => "'refer_to' parameter with path '@path': " .$e->description ); } my $element = pop @path; my $obj = $referred_to->parent; my $type = $obj->element_type($element); my @choice; if ( $type eq 'check_list' ) { @choice = $obj->fetch_element($element)->get_checked_list(); } elsif ( $type eq 'hash' ) { @choice = $obj->fetch_element($element)->fetch_all_indexes(); } elsif ( $type eq 'list' ) { my $list_obj = $obj->fetch_element($element); my $ct = $list_obj->get_cargo_type; if ( $ct eq 'leaf' ) { @choice = $list_obj->fetch_all_values( mode => 'user' ); } else { Config::Model::Exception::Model->throw( object => $obj, message => "element '$element' cargo_type is $ct. " . "Expected 'leaf'" ); } } else { Config::Model::Exception::Model->throw( object => $obj, message => "element '$element' type is $type. " . "Expected hash or list or check_list" ); } # use a hash so choices are unique push @enum_choice, @choice; } # prune out repeated items my %h; my @unique = grep { my $found = $h{$_} || 0; $h{$_} = 1; not $found; } @enum_choice; my @res; if ( $config_elt->value_type eq 'check_list' and $config_elt->ordered ) { @res = @unique; } else { @res = sort @unique; } $logger->debug( "Setting choice to '", join( "','", @res ), "'" ); $config_elt->setup_reference_choice(@res); } sub reference_info { my $self = shift; my $str = "choice was retrieved with: "; foreach my $compute_obj ( @{ $self->{compute} } ) { my $path = $compute_obj->formula; $path = defined $path ? "'$path'" : 'undef'; $str .= "\n\tpath $path"; $str .= "\n\t" . $compute_obj->compute_info; } return $str; } sub compute_obj { my $self = shift; return @{ $self->{compute} }; } sub reference_path { my $self = shift; return map { $_->formula } @{ $self->{compute} }; } __PACKAGE__->meta->make_immutable; 1; # ABSTRACT: Refer to id element(s) and extract keys __END__ =pod =encoding UTF-8 =head1 NAME Config::Model::IdElementReference - Refer to id element(s) and extract keys =head1 VERSION version 2.149 =head1 SYNOPSIS # synopsis shows an example of model of a network to use references use Config::Model; my $model = Config::Model->new; # model of several hosts with several NICs $model->create_config_class( name => 'Host', 'element' => [ ip_nic => { type => 'hash', index_type => 'string', cargo => { type => 'leaf', value_type => 'uniline', } }, ] ); # model to choose a master host and a master NIC (whatever that may be) # among configured hosts. Once these 2 are configured, the model computes # the master IP $model->create_config_class( name => "MyNetwork", element => [ host => { type => 'hash', index_type => 'string', cargo => { type => 'node', config_class_name => 'Host' }, }, # master_host is one of the configured hosts master_host => { type => 'leaf', value_type => 'reference', # provided by tConfig::Model::IdElementReference refer_to => '! host' }, # master_nic is one NIC of the master host master_nic => { type => 'leaf', value_type => 'reference', # provided by tConfig::Model::IdElementReference computed_refer_to => { # provided by Config::Model::ValueComputer formula => ' ! host:$h ip_nic ', variables => { h => '- master_host' } } }, # provided by Config::Model::ValueComputer master_ip => { type => 'leaf', value_type => 'string', compute => { formula => '$ip', variables => { h => '- master_host', nic => '- master_nic', ip => '! host:$h ip_nic:$nic' } } }, ], ); my $inst = $model->instance(root_class_name => 'MyNetwork' ); my $root = $inst->config_root ; # configure hosts on my network my $steps = 'host:foo ip_nic:eth0=192.168.0.1 ip_nic:eth1=192.168.1.1 - host:bar ip_nic:eth0=192.168.0.2 ip_nic:eth1=192.168.1.2 - host:baz ip_nic:eth0=192.168.0.3 ip_nic:eth1=192.168.1.3 '; $root->load( steps => $steps ); print "master host can be one of ", join(' ',$root->fetch_element('master_host')->get_choice),"\n" ; # prints: master host can be one of bar baz foo # choose master host $root->load('master_host=bar') ; print "master NIC of master host can be one of ", join(' ',$root->fetch_element('master_nic')->get_choice),"\n" ; # prints: master NIC of master host can be one of eth0 eth1 # choose master nic $root->load('master_nic=eth1') ; # check what is the master IP computed by the model print "master IP is ",$root->grab_value('master_ip'),"\n"; # prints master IP is 192.168.1.2 =head1 DESCRIPTION This class is user by L to set up an enumerated value where the possible choice depends on the key of a L or the content of a L object. This class is also used by L to define the checklist items from the keys of another hash (or content of a list). =head1 CONSTRUCTOR Construction is handled by the calling object (L). =head1 Config class parameters =over =item refer_to C is used to specify a hash element that is used as a reference. C points to an array or hash element in the configuration tree using the path syntax (See L for details). =item computed_refer_to When C is used, the path is computed using values from several elements in the configuration tree. C is a hash with 2 mandatory elements: C and C. =back The available choice of this (computed or not) reference value is made from the available keys of the C hash element or the values of the C array element. The example means the the value must correspond to an existing host: value_type => 'reference', refer_to => '! host' This example means the the value must correspond to an existing lan within the host whose Id is specified by hostname: value_type => 'reference', computed_refer_to => { formula => '! host:$a lan', variables => { a => '- hostname' } } If you need to combine possibilities from several hash, use the "C<+>" token to separate 2 paths: value_type => 'reference', computed_refer_to => { formula => '! host:$a lan + ! host:foobar lan', variables => { a => '- hostname' } } You can specify C or C with a C argument so the possible enum value will be the combination of the specified choice and the referred_to values. =head1 Methods =head2 reference_info Returns a human readable string with explains how is retrieved the reference. This method is mostly used to construct an error messages. =head1 AUTHOR Dominique Dumont, (ddumont at cpan dot org) =head1 SEE ALSO L, L, L, L =head1 AUTHOR Dominique Dumont =head1 COPYRIGHT AND LICENSE This software is Copyright (c) 2005-2022 by Dominique Dumont. This is free software, licensed under: The GNU Lesser General Public License, Version 2.1, February 1999 =cut Config-Model-2.149/lib/Config/Model/Exception.pm0000644000175000017500000003405514170053137017755 0ustar domidomi# # This file is part of Config-Model # # This software is Copyright (c) 2005-2022 by Dominique Dumont. # # This is free software, licensed under: # # The GNU Lesser General Public License, Version 2.1, February 1999 # package Config::Model::Exception 2.149; use warnings; use strict; use Data::Dumper; use Mouse; use v5.20; use Carp; use feature qw/postderef signatures/; no warnings qw/experimental::postderef experimental::signatures/; @Carp::CARP_NOT=qw/Config::Model::Exception Config::Model::Exception::Any/; our $trace = 0; use Carp qw/longmess shortmess croak/; use overload '""' => \&full_msg_and_trace, 'bool' => \&is_error; has description => ( is => 'ro', isa => 'Str', lazy_build => 1 ); sub _build_description { my $self = shift; return $self->_desc; } sub _desc { 'config error' } has object => ( is => 'rw', isa => 'Ref') ; has info => (is => 'rw', isa =>'Str', default => ''); has message => (is => 'rw', isa =>'Str', default => ''); has error => (is => 'rw', isa =>'Str', default => ''); has trace => (is => 'rw', isa =>'Str', default => ''); # need to keep these objects around: in some tests the error() method is # called after the instance is garbage collected. Instances are kept # as weak ref in node (and othe tree objects). When instance is # garbage collected, it's destroyed so error() can no longer be invoked. # Solution: keep instance as error attributes. has instance => ( is => 'rw', isa => 'Ref') ; sub BUILD ($self, $) { $self->instance($self->object->instance) if defined $self->object; } # without this overload, a test like if ($@) invokes '""' overload sub is_error { return ref ($_[0])} sub Trace { $trace = shift; } sub error_or_msg { my $self = shift; return $self->error || $self->message; } sub throw { my $class = shift; my $self = $class->new(@_); # when an exception is thrown, caught and rethrown, the first full # trace (provided by longmess) is clobbered by a second, shorter # trace (also provided by longmess). To avoid that, the first # trace must be stored. $self->trace($trace ? longmess : '') ; die $self; } sub rethrow { my $self = shift; die $self; } sub full_msg_and_trace { my $self = shift; my $msg = $self->full_message; $msg .= $self->trace; return $msg; } sub as_string { goto &full_msg_and_trace; } sub full_message { my $self = shift; my $obj = $self->object; my $location = defined $obj ? $obj->name : ''; my $msg = "Configuration item "; $msg .= "'$location' " if $location; $msg .= "has a " . $self->description; $msg .= ":\n\t" . ($self->error || $self->message) . "\n"; $msg .= $self->info . "\n" if $self->info; return $msg; } package Config::Model::Exception::Any 2.149; use Mouse; extends 'Config::Model::Exception'; package Config::Model::Exception::ModelDeclaration 2.149; use Mouse; extends 'Config::Model::Exception::Fatal'; sub _desc {'configuration model declaration error' } package Config::Model::Exception::User 2.149; use Mouse; extends 'Config::Model::Exception::Any'; sub _desc {'user error' } ## old classes below package Config::Model::Exception::Syntax 2.149; use Mouse; extends 'Config::Model::Exception::Any'; sub _desc { 'syntax error' } has [qw/parsed_file parsed_line/] => (is => 'rw'); sub full_message { my $self = shift; my $fn = $self->parsed_file || '?'; my $line = $self->parsed_line || '?'; my $msg = "File $fn line $line "; $msg .= "has a " . $self->description; $msg .= ":\n\t" . $self->error_or_msg . "\n"; return $msg; } package Config::Model::Exception::LoadData 2.149; use Mouse; extends 'Config::Model::Exception::User'; sub _desc { 'Load data structure (perl) error' }; has wrong_data => (is => 'rw'); sub full_message { my $self = shift; my $obj = $self->object; my $location = defined $obj ? $obj->name : ''; my $msg = "Configuration item "; my $d = Data::Dumper->new( [ $self->wrong_data ], ['wrong data'] ); $d->Sortkeys(1); $msg .= "'$location' " if $location; $msg .= "(class " . $obj->config_class_name . ") " if $obj->get_type eq 'node'; $msg .= "has a " . $self->description; $msg .= ":\n\t" . $self->error_or_msg . "\n"; $msg .= $d->Dump; return $msg; } package Config::Model::Exception::Model 2.149; use Carp; use Mouse; extends 'Config::Model::Exception::Fatal'; sub _desc { 'configuration model error'} sub full_message { my $self = shift; my $obj = $self->object || croak "Internal error: no object parameter passed while throwing exception"; my $msg; if ( $obj->isa('Config::Model::Node') ) { $msg = "Node '" . $obj->name . "' of class " . $obj->config_class_name . ' '; } else { my $element = $obj->element_name; my $level = $obj->parent->get_element_property( element => $element, property => 'level' ); my $location = $obj->location; $msg = "In config class '" . $obj->parent->config_class_name. "',"; $msg .= " (location: $location)" if $location; $msg .= " element '$element' (level $level) "; } $msg .= "has a " . $self->description; $msg .= ":\n\t" . $self->error_or_msg . "\n"; return $msg; } package Config::Model::Exception::Load 2.149; 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 2.149; 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 2.149; use Mouse; extends 'Config::Model::Exception::User'; sub _desc { 'unknown ancestor class'} package Config::Model::Exception::ObsoleteElement 2.149; use Mouse; extends 'Config::Model::Exception::User'; sub _desc { 'Obsolete element' } has element => (is => 'rw', isa => 'Str'); sub full_message { my $self = shift; my $obj = $self->object; my $element = $self->element; my $msg = $self->description; my $location = $obj->name; my $help = $obj->get_help_as_text($element) || ''; $msg .= " '$element' in node '$location'.\n"; $msg .= "\t$help\n"; $msg .= "\t" . $self->info . "\n" if defined $self->info; return $msg; } package Config::Model::Exception::UnknownElement 2.149; 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 .= "Configuration path '" . $self->where . "': " if defined $self->where; $msg .= "(function '" . $self->function . "') " if defined $self->function; $msg = "object '" . $obj->name . "' error: " unless $msg; $msg .= $self->description . " '" . $self->element . "'."; # retrieve a support url from application info to guide user toward the right bug tracker my $info = $obj->instance->get_support_info // 'to https://github.com/dod38fr/config-model/issues'; $msg .= " Either your file has an error or $class_name model is lagging behind. " . "In the latter case, please submit a bug report $info. See cme man " . "page for details.\n"; if (@elements) { $msg .= "\tExpected elements: '" . join( "','", @elements ) . "'\n"; } else { $msg .= " (node is warped out)\n"; } my @match_keys = $obj->can('accept_regexp') ? $obj->accept_regexp() : (); if (@match_keys) { $msg .= "\tor an acceptable parameter matching '" . join( "','", @match_keys ) . "'\n"; } # inform about available elements after a change of warp master value if ( defined $obj->parent ) { my $parent = $obj->parent; my $element_name = $obj->element_name; if ( $parent->element_type($element_name) eq 'warped_node' ) { $msg .= "\t" . $parent->fetch_element( name => $element_name, qw/check no accept_hidden 1/ )->warp_error; } } $msg .= "\t" . $self->info . "\n" if ( defined $self->info ); return $msg; } package Config::Model::Exception::WarpError 2.149; use Mouse; extends 'Config::Model::Exception::User'; sub _desc { 'warp error'} package Config::Model::Exception::Fatal 2.149; use Mouse; extends 'Config::Model::Exception::Any'; sub _desc { 'fatal error' } package Config::Model::Exception::UnknownId 2.149; 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 2.149; use Mouse; extends 'Config::Model::Exception::User'; sub _desc { 'wrong value'}; package Config::Model::Exception::WrongType 2.149; use Mouse; extends 'Config::Model::Exception::User'; sub _desc { 'wrong element type' }; has [qw/function got_type/] => (is => 'rw', isa => 'Str'); has [qw/expected_type/] => (is => 'rw'); sub full_message { my $self = shift; my $obj = $self->object; my $msg = ''; $msg .= "In function " . $self->function . ": " if defined $self->function; my $type = $self->expected_type; $msg .= $self->description . " for element '" . $obj->location . "'\n\tgot type '" . $self->got_type . "', expected '" . (ref $type ? join("' or '",@$type) : $type) . "' " . $self->info . "\n"; return $msg; } package Config::Model::Exception::ConfigFile 2.149; use Mouse; extends 'Config::Model::Exception::User'; sub _desc { 'error in configuration file' } package Config::Model::Exception::ConfigFile::Missing 2.149; use Mouse; use Mouse::Util::TypeConstraints; extends 'Config::Model::Exception::ConfigFile'; sub _desc { 'missing configuration file'} subtype 'ExcpPathTiny', as 'Object', where {$_->isa('Path::Tiny')} ; has file => (is => 'rw', isa => 'Str | ExcpPathTiny' ); sub full_message { my $self = shift; return "Error: cannot find configuration file " . $self->file . "\n"; } package Config::Model::Exception::Formula 2.149; use Mouse; extends 'Config::Model::Exception::Model'; sub _desc { 'error in computation formula of the configuration model'} package Config::Model::Exception::Internal 2.149; 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.149 =head1 SYNOPSIS use Config::Model::Exception; # later my $kaboom = 1; Config::Model::Exception::Model->throw( error => "Went kaboom", object => $self ) if $kaboom; =head1 DESCRIPTION This module creates exception classes used by L. All exception class name begins with C The exception classes are: =over =item C Base class. It accepts an C argument. The user must pass the reference of the object where the exception occurred. The object name is used to generate the error message. =back TODO: list all exception classes and hierarchy. =head1 How to get trace By default, most of the exceptions do not print out the stack trace. For debug purpose, you can force a stack trace for all exception classes: Config::Model::Exception->Trace(1) ; =head1 AUTHOR Dominique Dumont, (ddumont at cpan dot org) =head1 SEE ALSO L, L, L, L =head1 AUTHOR Dominique Dumont =head1 COPYRIGHT AND LICENSE This software is Copyright (c) 2005-2022 by Dominique Dumont. This is free software, licensed under: The GNU Lesser General Public License, Version 2.1, February 1999 =cut Config-Model-2.149/lib/Config/Model/Warper.pm0000644000175000017500000006404514170053137017261 0ustar domidomi# # This file is part of Config-Model # # This software is Copyright (c) 2005-2022 by Dominique Dumont. # # This is free software, licensed under: # # The GNU Lesser General Public License, Version 2.1, February 1999 # package Config::Model::Warper 2.149; use Mouse; use Log::Log4perl qw(get_logger :levels); use Data::Dumper; use Storable qw/dclone/; use Config::Model::Exception; use List::MoreUtils qw/any/; 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 => ['needs_check'], 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 [qw/ _computed_masters _warped_nodes _registered_values/] => ( is => 'rw', isa => 'HashRef', init_arg => undef, # can't use this param in constructor 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->trace( "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 any {$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->trace("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->trace("Warper compute_bool: eval code '$perl_code'"); my $ret; { my $warped_obj = $self->warped_object ; no warnings "uninitialized"; $ret = eval($perl_code); ## no critic (ProhibitStringyEval) } 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->trace( "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->trace( "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.149 =head1 SYNOPSIS # internal class =head1 DESCRIPTION Depending on the value of a warp master (In fact a L or a L object), this class changes 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 is 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 is 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 is 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 is 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 is sanitized and used in a Perl eval, so you can use most Perl syntax and regular expressions. Functions (like C<&foo>) are 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 registers 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 are modified. =back =item Master update =over =item * When a warp master value is updated, the warp master calls I its warped object and pass them the new master value. =item * Then each warped object modifies 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-2022 by Dominique Dumont. This is free software, licensed under: The GNU Lesser General Public License, Version 2.1, February 1999 =cut Config-Model-2.149/lib/Config/Model/WarpedNode.pm0000644000175000017500000003616414170053137020052 0ustar domidomi# # This file is part of Config-Model # # This software is Copyright (c) 2005-2022 by Dominique Dumont. # # This is free software, licensed under: # # The GNU Lesser General Public License, Version 2.1, February 1999 # package Config::Model::WarpedNode 2.149; use Mouse; 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/; with "Config::Model::Role::NodeLoader"; with "Config::Model::Role::Grab"; 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 gist/; has 'backup' => ( is => 'rw', isa => 'HashRef', default => sub { {}; } ); has 'warp' => ( is => 'rw', isa => 'HashRef', default => sub { {}; }); 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 registers this object in a Value object (the # warper). When the warper gets a new value, it modifies the # WarpedNode according to the data passed by the user. my $warp_info = $self->warp; $warp_info->{follow} //= {}; $warp_info->{rules} //= []; my $w = Config::Model::Warper->new( warped_object => $self, %$warp_info, 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 get_info fetch_gist has_element is_element_available element_type load fetch_element_value get_type get_cargo_type dump_tree needs_save describe get_help get_help_as_text children get set accept_regexp/ ) { # to register new methods in package no strict "refs"; ## no critic TestingAndDebugging::ProhibitNoStrict *$method = sub { my $self = shift; if ($self->check) { return $self->{data}->$method(@_); } # return undef if no class was warped in return ; }; } 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 for (@allowed_warp_params) { delete $self->{$_} } $logger->trace( $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 changes the tree. And these changes below triggers # 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 does # NOT trigger notify_changes from below. So notify_change must be called if ( defined $old_object and $old_config_class_name) { 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.149 =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', warp => } 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( steps => '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( steps => '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 specifies one (or several) leaf in the configuration tree that triggers the actual property change of the warped node. This leaf is also referred as I. When the warp master(s) value(s) changes, C creates 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 tries to recursively copy the value from the old object to the new object using L. When a copy is not possible, undef values are 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 creates a new object of the type specified by this parameter: XZ => { config_class_name => 'SlaveZ' } Instead of a string, you can an array ref which contains 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 Parameters: C<< ( 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 is not available. Trying to access C raises an exception. =item * When C is changed from C to C, C refers to a brand new C object constructed with C<< ClassX->new(foo => 'bar') >> =item * Then, if C is changed from C to C, C refers to a brand new C object. But in this case, the object is initialized with most if not all the attributes of C. This copy is 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-2022 by Dominique Dumont. This is free software, licensed under: The GNU Lesser General Public License, Version 2.1, February 1999 =cut Config-Model-2.149/lib/Config/Model/BackendMgr.pm0000644000175000017500000005462714170053137020023 0ustar domidomi# # This file is part of Config-Model # # This software is Copyright (c) 2005-2022 by Dominique Dumont. # # This is free software, licensed under: # # The GNU Lesser General Public License, Version 2.1, February 1999 # package Config::Model::BackendMgr 2.149; use Mouse; use strict; use warnings; use Carp; use 5.10.1; use Config::Model::Exception; use Data::Dumper; use Storable qw/dclone/; use Scalar::Util qw/weaken reftype/; use Log::Log4perl qw(get_logger :levels); use Path::Tiny 0.070; my $logger = get_logger('BackendMgr'); my $user_logger = get_logger('User'); # one BackendMgr per file has 'node' => ( is => 'ro', isa => 'Config::Model::Node', weak_ref => 1, required => 1 ); has 'file_backup' => ( is => 'rw', isa => 'ArrayRef', default => sub { [] } ); has 'rw_config' => ( is => 'ro', isa => 'HashRef', required => 1 ); has 'backend_obj' => ( is => 'rw', isa => 'Config::Model::Backend::Any', lazy => 1 , builder => '_build_backend_obj', ); sub _build_backend_obj { my $self = shift; my $backend = $self->rw_config->{backend}; $logger->warn("function parameter for a backend is deprecated. Please implement 'read' method in backend $backend") if $self->rw_config->{function}; # try to load a specific Backend class my $f = $self->rw_config->{function} || 'read'; my $c = $self->load_backend_class( $backend, $f ); no strict 'refs'; ## no critic (ProhibitNoStrict) return $c->new( node => $self->node, name => $backend, auto_create => $self->rw_config->{auto_create}, auto_delete => $self->rw_config->{auto_delete}, ); } has support_annotation => ( is => 'ro', isa => 'Bool', default => 0, ); with "Config::Model::Role::ComputeFunction"; with "Config::Model::Role::FileHandler"; # check if dir is present. May create it in auto_create write mode sub get_cfg_dir_path { my $self = shift; my %args = @_; my $w = $args{write} || 0; my $dir = $self->get_tuned_config_dir(%args); if ( not $dir->is_dir and $w and $args{auto_create} ) { $logger->info("creating directory $dir"); $dir->mkpath; } unless ( $dir->is_dir ) { my $mode = $w ? 'write' : 'read'; $logger->info( "$args{backend}: missing directory $dir ($mode mode)" ); return ( 0, $dir ); } $logger->trace( "dir: " . $dir // '' ); return ( 1, $dir ); } # return (1, config file path) constructed from arguments or return # (0). May create directory in auto_create write mode. sub get_cfg_file_path { my $self = shift; my %args = @_; my $w = $args{write} || 0; # config file override my $cfo = $args{config_file}; if ( defined $cfo) { my $override = $args{root} ? $args{root}->child($cfo) : $cfo =~ m!^/! ? path($cfo) : path('.')->child($cfo); my $mode = $w ? 'write' : 'read'; $logger->trace("$args{backend} override target file is $override ($mode mode)"); return ( 1, $override ); } my ( $dir_ok, $dir ) = $self->get_cfg_dir_path(%args); if ( defined $args{file} ) { my $file = $args{skip_compute} ? $args{file} : $self->node->compute_string($args{file}); my $res = $dir->child($file); $logger->trace("get_cfg_file_path: returns $res"); return ( $dir_ok, $res ); } return 0; } sub open_read_file { my ($self, $file_path) = @_; if ( $file_path->is_file ) { $logger->debug("open_read_file: open $file_path for read"); # store a backup in memory in case there's a problem $self->file_backup( [ $file_path->lines_utf8 ] ); return $file_path->filehandle("<", ":utf8"); } else { return; } } # called at configuration node creation # # New subroutine "load_backend_class" extracted - Thu Aug 12 18:32:37 2010. # sub load_backend_class { my $self = shift; my $backend = shift; my $function = shift; $logger->trace("load_backend_class: called with backend $backend, function $function"); my %c; my $k = "Config::Model::Backend::" . ucfirst($backend); my $f = $k . '.pm'; $f =~ s!::!/!g; $c{$k} = $f; # try another class $k =~ s/_(\w)/uc($1)/ge; $f =~ s/_(\w)/uc($1)/ge; $c{$k} = $f; foreach my $c ( sort keys %c ) { if ( $c->can($function) ) { # no need to load class $logger->debug("load_backend_class: $c is already loaded (can $function)"); return $c; } } # look for file to load my $class_to_load; foreach my $c ( sort keys %c ) { $logger->trace("load_backend_class: looking to load class $c"); foreach my $prefix (@INC) { my $realfilename = "$prefix/$c{$c}"; $class_to_load = $c if -f $realfilename; } } if (not defined $class_to_load) { Config::Model::Exception::Model->throw( object => $self->node, error => "backend error: cannot find Perl class for backend: '$backend'", ); }; my $file_to_load = $c{$class_to_load}; $logger->trace("load_backend_class: loading class $class_to_load, $file_to_load"); eval { require $file_to_load; }; if ($@) { die "Error with backend $backend: could not parse $file_to_load: $@\n"; } return $class_to_load; } sub read_config_data { my ( $self, %args ) = @_; $logger->trace( "called for node ", $self->node->location ); my $check = delete $args{check}; my $config_file_override = delete $args{config_file}; my $auto_create_override = delete $args{auto_create}; croak "unexpected args " . join( ' ', keys %args ) . "\n" if %args; my $rw_config = dclone $self->rw_config ; my $instance = $self->node->instance(); # root override is passed by the instance my $root_dir = $instance->root_dir ; my $auto_create = $rw_config->{auto_create}; my $backend = $rw_config->{backend}; if ( $rw_config->{default_layer} ) { $self->read_config_sub_layer( $rw_config, $root_dir, $config_file_override, $check, $backend ); } my ( $res, $file ) = $self->try_read_backend( $rw_config, $root_dir, $config_file_override, $check, $backend ); Config::Model::Exception::ConfigFile::Missing->throw ( file => $file || "", object => $self->node, ) unless $res or $auto_create_override or $auto_create; } sub read_config_sub_layer { my ( $self, $rw_config, $root_dir, $config_file_override, $check, $backend ) = @_; my $layered_config = delete $rw_config->{default_layer}; my $layered_read = dclone $rw_config ; foreach my $item ( qw/file config_dir os_config_dir/ ) { my $lc = delete $layered_config->{$item}; $layered_read->{$item} = $lc if $lc; } Config::Model::Exception::Model->throw( error => "backend error: unexpected default_layer parameters: " . join( ' ', sort keys %$layered_config ), object => $self->node, ) if %$layered_config; my $i = $self->node->instance; my $already_in_layered = $i->layered; # layered stuff here if ( not $already_in_layered ) { $i->layered_clear; $i->layered_start; } $self->try_read_backend( $layered_read, $root_dir, $config_file_override, $check, $backend ); if ( not $already_in_layered ) { $i->layered_stop; } } # called at configuration node creation, NOT when writing # # New subroutine "try_read_backend" extracted - Sun Jul 14 11:52:58 2013. # sub try_read_backend { my $self = shift; my $rw_config = shift; my $root_dir = shift; my $config_file_override = shift; my $check = shift; my $backend = shift; my $read_dir = $self->get_tuned_config_dir(%$rw_config); my @read_args = ( %$rw_config, root => $root_dir, config_dir => $read_dir, backend => $backend, check => $check, config_file => $config_file_override ); my $backend_obj = $self->backend_obj(); if ($backend_obj->can('suffix')) { $logger->warn("suffix method is deprecated. you can remove it from backend $backend"); } my ( $file_ok, $file_path ) = $self->get_cfg_file_path( @read_args, skip_compute => $backend_obj->skip_open, ); my $fh; if (not $backend_obj->skip_open and $file_ok) { $fh = $self->open_read_file($file_path) ; } my $f = $self->rw_config->{function} || 'read'; if ($logger->is_info) { my $fp = defined $file_path ? " on $file_path":'' ; $logger->info( "Read with $backend " . reftype($backend_obj) . "::$f".$fp); } my $res; eval { $res = $backend_obj->$f( @read_args, file_path => $file_path, io_handle => Config::Model::DeprecatedHandle->new($fh), object => $self->node, ); }; my $error = $@; # catch eval error if ( ref($error) and $error->isa('Config::Model::Exception::Syntax') ) { $error->parsed_file( $file_path) unless $error->parsed_file; $error->rethrow; } elsif ( ref $error and $error->isa('Config::Model::Exception') ) { $error->rethrow ; } elsif ( ref $error ) { die $error ; } elsif ( $error ) { die "Backend $backend failed to read $file_path: $error"; } # only backend based on C::M::Backend::Any can support annotations if ($backend_obj->can('annotation')) { $self->{support_annotation} = $backend_obj->annotation ; } return ( $res, $file_path ); } sub auto_write_init { my ( $self, %args ) = @_; croak "auto_write_init: unexpected args " . join( ' ', sort keys %args ) . "\n" if %args; my $rw_config = dclone $self->rw_config ; my $instance = $self->node->instance(); # root override is passed by the instance my $root_dir = $instance->root_dir; my $backend = $rw_config->{backend}; my $write_dir = $self->get_tuned_config_dir(%$rw_config); $logger->trace( "auto_write_init creating write cb ($backend) for ", $self->node->name ); my @wr_args = ( %$rw_config, # model data config_dir => $write_dir, # override from instance write => 1, # for get_cfg_file_path root => $root_dir, # override from instance ); # used bby C::M::Dumper and C::M::DumpAsData # TODO: is this needed once multi backend are removed $self->{auto_write}{$backend} = 1; my $wb; my $f = $rw_config->{function} || 'write'; my $backend_class = $self->load_backend_class( $backend, $f ); my $location = $self->node->name; my $node = $self->node; # closure # provide a proper write back function $wb = sub { my %cb_args = @_; my $force_delete = delete $cb_args{force_delete} ; $logger->debug( "write cb ($backend) called for $location ", $force_delete ? '' : ' (deleted)' ); my $backend_obj = $self->backend_obj(); my ($fh, $file_ok, $file_path ); if (not $backend_class->skip_open) { ( $file_ok, $file_path ) = $self->get_cfg_file_path( @wr_args, %cb_args); } if ($file_ok) { $fh = $self->open_file_to_write( $backend, $file_path, delete $cb_args{backup} ); } # override needed for "save as" button my %backend_args = ( @wr_args, io_handle => Config::Model::DeprecatedHandle->new($fh), file_path => $file_path, object => $node, %cb_args # override from user ); my $res; if ($force_delete) { $backend_obj->delete(%backend_args); } else { $res = eval { $backend_obj->$f( %backend_args ); }; my $error = $@; $logger->error( "write backend $backend $backend_class" . '::' . "$f failed: $error" ) if $error; $self->close_file_to_write( $error, $file_path, $rw_config->{file_mode} ); $self->auto_delete($file_path, \%backend_args) if $rw_config->{auto_delete} and not $backend_class->skip_open ; } return defined $res ? $res : $@ ? 0 : 1; }; # FIXME: enhance write back mechanism so that different backend *and* different nodes # work as expected $logger->trace( "registering write $backend in node " . $self->node->name ); $instance->register_write_back( $self->node->location, $backend, $wb ); } sub auto_delete { my ($self, $file_path, $args) = @_; return unless $file_path; my $perl_data; $perl_data = $self->node->dump_as_data( full_dump => $args->{full_dump} // 0) if defined $self->node; my $size = ref($perl_data) eq 'HASH' ? scalar keys %$perl_data : ref($perl_data) eq 'ARRAY' ? scalar @$perl_data : $perl_data ; if (not $size) { $logger->info( "Removing $file_path (no data to store)" ); unlink($file_path); } } sub open_file_to_write { my ( $self, $backend, $file_path, $backup ) = @_; my $do_backup = defined $backup; $backup ||= 'old'; # use old only if defined $backup = '.' . $backup unless $backup =~ /^\./; # make sure that parent dir exists before creating file $file_path->parent->mkpath; if ( $do_backup and $file_path->is_file ) { $file_path->copy( $file_path.$backup ) or die "Backup copy failed: $!"; } $logger->debug("$backend backend opened file $file_path to write"); return $file_path->filehandle(">",":utf8"); } sub close_file_to_write { my ( $self, $error, $file_path, $file_mode ) = @_; return unless defined $file_path; if ($error) { # restore backup and display error $logger->warn("Error during write, restoring backup data in $file_path" ); $file_path->append_utf8({ truncate => 1 }, $self->file_backup ); $error->rethrow if ref($error) and $error->can('rethrow'); die $error; } # TODO: move chmod in a backend role $file_path->chmod($file_mode) if $file_mode; # TODO: move in a backend role # check file size and remove empty files $file_path->remove if -z $file_path and not -l $file_path; } sub is_auto_write_for_type { my $self = shift; my $type = shift; return $self->{auto_write}{$type} || 0; } __PACKAGE__->meta->make_immutable; package Config::Model::DeprecatedHandle 2.149; our $AUTOLOAD; sub new { my $class = shift; my $fh = shift; return defined $fh ? bless \$fh, $class : undef; } sub AUTOLOAD { my $self = shift; my $f = $AUTOLOAD; $f =~ s/.*:://; my ($package, $filename, $line) = caller; # $$self may not be defined during destruction if ($$self and $self->can($f)) { $logger->warn( "io_handle backend parameter is deprecated, ", "please use file_path parameter. ", "(called $f at $filename:$line)" ) unless $package eq "Config::Model::BackendMgr"; $$self->$f(@_); } } 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.149 =head1 SYNOPSIS # Use BackendMgr to write data in Yaml file # This example requires Config::Model::Backend::Yaml which is now # shipped outside of Config::Model. Please get it on CPAN use Config::Model; # define configuration tree object my $model = Config::Model->new; $model->create_config_class( name => "Foo", element => [ [qw/foo bar/] => { type => 'leaf', value_type => 'string' }, ] ); $model->create_config_class( name => "MyClass", # rw_config spec is used by Config::Model::BackendMgr rw_config => { backend => 'yaml', config_dir => '/tmp/', file => 'my_class.yml', auto_create => 1, }, element => [ [qw/foo bar/] => { type => 'leaf', value_type => 'string' }, hash_of_nodes => { type => 'hash', # hash id index_type => 'string', cargo => { type => 'node', config_class_name => 'Foo' }, }, ], ); my $inst = $model->instance( root_class_name => 'MyClass' ); my $root = $inst->config_root; # put data my $steps = 'foo=FOO hash_of_nodes:fr foo=bonjour - hash_of_nodes:en foo=hello '; $root->load( steps => $steps ); $inst->write_back; # now look at file /tmp/my_class.yml =head1 DESCRIPTION This class provides a way to specify how to load or store configuration data within the model. With these specifications, all configuration information is read during creation of a node (which triggers the creation of a backend manager object) and written back when L method is called either on the instance. =begin comment This feature is also useful if you want to read configuration class declarations at run time. (For instance in a C directory like C). In this case, each configuration class must specify how to read and write configuration information. Idea: sub-files name could be %.cds =end comment This load/store can be done with different backends: =over =item * Any of the C classes available on your system. For instance C. =item * C: Config dump string (cds) in a file. I.e. a string that describes the content of a configuration tree is loaded from or saved in a text file. This format is defined by this project. See L. =item * C: Perl data structure (perl) in a file. See L for details on the data structure. Now handled by L =back When needed, C method can be called on the instance (See L) to store back all configuration information. =head1 Backend specification The backend specification is provided as an attribute of a L specification. These attributes are optional: A node without C attribute must rely on another node to read or save its data. When needed (usually for the root node), the configuration class is declared with a C parameter which specifies the read/write backend configuration. =head2 Parameters available for all backends The following parameters are accepted by all backends: =over 4 =item config_dir Specify configuration directory. This parameter is optional as the directory can be hardcoded in the backend class. C beginning with 'C<~>' is munged so C<~> is replaced by C<< File::HomeDir->my_data >>. See L for details. =item file Specify configuration file name (without the path). This parameter is optional as the file name can be hardcoded in the backend class. The configuration file name can be specified with C<&index> keyword when a backend is associated to a node contained in a hash. For instance, with C set to C<&index.conf>: service # hash element foo # hash index nodeA # values of nodeA are stored in foo.conf bar # hash index nodeB # values of nodeB are stored in bar.conf Likewise, the keyword C<&element> can be used to specify the file name. For instance, with C set to C<&element-&index.conf>: service # hash element foo # hash index nodeA # values of nodeA are stored in service.foo.conf bar # hash index nodeB # values of nodeB are stored in service.bar.conf =item file_mode C parameter can be used to set the mode of the written file(s). C value can be in any form supported by L. Example: file_mode => 0664, file_mode => '0664', file_mode => 'g+w' =item os_config_dir Specify alternate location of a configuration directory depending on the OS (as returned by C<$^O>, see L). For instance: config_dir => '/etc/ssh', os_config_dir => { darwin => '/etc' } =item default_layer Optional. Specifies where to find a global configuration file that specifies default values. For instance, this is used by OpenSSH to specify a global configuration file (C) that is overridden by user's file: default_layer => { os_config_dir => { 'darwin' => '/etc' }, config_dir => '/etc/ssh', file => 'ssh_config' } Only the 3 above parameters can be specified in C. =item auto_create By default, an exception is thrown if no read was successful. This behavior can be overridden by specifying C<< auto_create => 1 >> in one of the backend specification. For instance: rw_config => { backend => 'IniFile', config_dir => '/tmp', file => 'foo.conf', auto_create => 1 }, Setting C to 1 is necessary to create a configuration from scratch =item auto_delete Delete configuration files that contains no data. (default is to leave an empty file) =back =head2 Config::Model::Backend::* backends Specify the backend name and the parameters of the backend defined in their documentation. For instance: rw_config => { backend => 'yaml', config_dir => '/tmp/', file => 'my_class.yml', }, See L for more details for this backend. =head2 Your own backend You can also write a dedicated backend. See L for details. =head1 Test setup By default, configurations files are read from the directory specified by C parameter specified in the model. You may override the C directory for test. =head1 Methods =head2 support_annotation Returns 1 if at least the backend supports read and write annotations (aka comments) in the configuration file. =head1 AUTHOR Dominique Dumont, (ddumont at cpan dot org) =head1 SEE ALSO L, L, L, L =head1 AUTHOR Dominique Dumont =head1 COPYRIGHT AND LICENSE This software is Copyright (c) 2005-2022 by Dominique Dumont. This is free software, licensed under: The GNU Lesser General Public License, Version 2.1, February 1999 =cut Config-Model-2.149/lib/Config/Model/Manual/0000755000175000017500000000000014170053137016667 5ustar domidomiConfig-Model-2.149/lib/Config/Model/Manual/ModelCreationAdvanced.pod0000644000175000017500000002113014170053137023543 0ustar domidomi# 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.149 =head1 Introduction The page L explains what is a configuration tree and a configuration model and how to create a simple configuration model. But a configuration model can be more complex and define interactions between elements with the following features: =over =item * Model warp. For instance, Xorg driver options change depending on driver name (C, C...) =item * Simple computation from other elements (used for upgrades) =item * References. For instance, in C, C name must refer to one of the monitors declared in C section. =back Caveat: Xorg examples are based on Xorg 1.4 and may not be valid for Xorg 1.5 or 1.6 =head1 Model plugin Config::Model can also use model plugins. Each model can be augmented by model snippets stored into directory C<< .d >>. All files found there are merged to existing model. For instance, this model in file C<.../Config/Model/models/Fstab/Fsline.pl>: { name => "Fstab::Fsline", element => [ fs_vfstype => { type => 'leaf', value_type => 'enum', choice => [ qw/ext2 ext3/ ], }, fs_mntopts => { type => 'warped_node', follow => { 'f1' => '- fs_vfstype' }, rules => [ '$f1 eq \'ext2\'', { 'config_class_name' => 'Fstab::Ext2FsOpt' }, '$f1 eq \'ext3\'', { 'config_class_name' => 'Fstab::Ext3FsOpt' }, ], } ] } can be augmented with the content of C<.../Config/Model/models/Fstab/Fsline.d/addext4.pl>: { name => "Fstab::Fsline", element => [ fs_vfstype => { choice => [ qw/ext4/ ], }, fs_mntopts => { rules => [ q!$f1 eq 'ext4'!, { 'config_class_name' => 'Fstab::Ext4FsOpt' }, ], }, ] } ; Then, the merged model will feature C with choice C. Likewise, C will feature rules for the 3 filesystems. Under the hood, L method is used to load model snippets. =head1 Model warp From a user's point of view, model warp looks like the structure or properties of the configuration is changing (or adapting) dynamically depending on the values being entered. For instance, when changing a driver name from C to C, some options disappear from the GUI and some other options pop-in. Model warping need not be that spectacular and can have more subtle effect like changing a default value. Of course, there's no magic, model warp properties needs to be prepared and declared in the model. =head2 Warped value Let's start simple with value warp: the properties of a single value is changed dynamically. Let's imagine a configuration file with 2 values: I which can be set to I or I and I whose maximum value is 10 when size is small and 50 when size is big. (this may be dumb, but it's for the sake of the example). So the basic model without warp is element => [ size => { type => 'leaf', value_type => 'enum', choice => ['big','small'], }, length => { type => 'leaf', value_type => 'integer', max => '10', }, ] Now we need to declare the relationship between I and I to be able to change dynamically the I property. This setup is made of 2 specifications: =over =item * what is the element that triggers the change (called I in the doc) =item * what is the effect of the warp master change =back The first is done with a declaration of the I to I to find the warp master (associated to a variable). The second is a set of value properties: element => [ size => { type => 'leaf', value_type => 'enum', choice => ['big','small'], }, length => { type => 'leaf', value_type => 'integer', warp => { # change specification follow => { # declare what trigger the change size_type => '- size' # size_type: go 1 level above and fetch # size value }, rules => { # how to apply change '$size_type eq "small"' => { # set max to 10 when size is small max => 10 }, '$size_type eq "big" ' => { # set max to 50 when size is big max => 50 }, }, }, } ] =head2 Warp in or warp out an element Here's a real use case scenario from OpenSsh. C enables a user to set up a tunnel through ssh. The input of this tunnel can listen to localhost (default) or to other hosts. These other hosts are specified by the I part of the C parameter. But this bind address is ignored if C is false (which is the default). In order to present only meaningful parameters to the user, I parameter must be hidden when C is false and shown when C is true. Here's the recipe. First create a boolean element for C: GatewayPorts => { type => 'leaf', value_type => 'boolean', upstream_default => 0, }, And C that provides I parameter: LocalForward => { type => 'list', cargo => { type => 'node', config_class_name => 'Ssh::PortForward' }, summary => 'Local port forwarding', } In C configuration class, declare I with the warp instructions: bind_address => { type => 'leaf', value_type => 'uniline', level => 'hidden', # by default, is hidden from user warp => { # instructions to show bind_address follow => { # specify what does trigger the change gp => '- - GatewayPorts' # gp: go to 2 levels above in tree ('- -') and # fetch GatewayPorts value }, rules => [ # specify how to apply the change triggered by gp '$gp' => { # apply change when $gp is true level => 'normal' # set level to normal (instead of 'hidden'). This change # will show this parameter in the UI } ] }, }, =head2 warped node Sometimes, warping a value line by line is not practical. For instance, in C the mount options of a file system change drastically from one file system to another. In this case, it's better to swap a configuration class with another. For instance, swap C mount options with C mount options when a file system is changed from C to C. Here's how this can be done. First declare the C parameter: fs_vfstype => { type => 'leaf', mandatory => 1, value_type => 'enum', choice => [ 'auto', 'davfs', 'vfat', 'ext2', 'ext3', ] , # etc ... } Then declare C as a B (not a simple C)) that uses C to swap one config class with another: fs_mntopts => { type => 'warped_node', # a shape-shifting node follow => { f1 => '- fs_vfstype' , # use fs_vfstype as a trigger }, rules => [ # condition => effect: config class to swap in "$f1 eq 'proc'" => { config_class_name => 'Fstab::CommonOptions' }, "$f1 eq 'auto'" => { config_class_name => 'Fstab::CommonOptions' }, "$f1 eq 'vfat'" => { config_class_name => 'Fstab::CommonOptions' }, "$f1 eq 'swap'" => { config_class_name => 'Fstab::SwapOptions' }, "$f1 eq 'ext3'" => { config_class_name => 'Fstab::Ext3FsOpt' }, # etc ... ] } =head1 References =head1 Computation and migrations =head2 Cascaded warp Config::Model also supports cascaded warps: A warped value is dependent on another value which is itself a warped value. =head1 Feedback welcome Feel free to send comments and suggestion about this page at config-model-users at lists dot sourceforge dot net. =head1 AUTHORS Dominique Dumont =head1 AUTHOR Dominique Dumont =head1 COPYRIGHT AND LICENSE This software is Copyright (c) 2005-2022 by Dominique Dumont. This is free software, licensed under: The GNU Lesser General Public License, Version 2.1, February 1999 =cut Config-Model-2.149/lib/Config/Model/Manual/ModelCreationIntroduction.pod0000644000175000017500000005136414170053137024533 0ustar domidomi# 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.149 =head1 Introduction This page describes how to write a simple configuration model. Creation of more complex models are described in L. Note that this document shows a lot of Perl data structure to highlight the content of a model. A Perl data structure is very similar to a JSON structure. The only thing you need to know are: =over =item * Curly braces C<{ ... }> contain a dictionary of key, value pairs (a C in Perl land)) =item * Square brackets C<[ ... ]> contain a list of items (C or C in Perl land) =back =head1 Some definitions =over =item configuration file Text file where configuration data are stored. This configuration file is used by an application -- the I =item configuration tree The semantic content of the configuration file stored in a tree representation =item configuration model Structure and constraints of the configuration tree. Like a schema for the configuration tree =item target application The application that uses the configuration file. The application can be of type C (i.e. the configuration file is located in C), C (i.e. the configuration file is located in a user directory like C<~/.config>) or C (the configuration file is in or below the current directory) =item end user User of the target application =item application developer Target application developer =item model developer People developing the configuration model. Not necessarily the application developer =back =head1 What is a configuration tree? Most configuration files are actually organized mostly as a tree structure. Depending on the syntax of the file, this structure may be obvious to see (e.g. for XML, Apache) or not so obvious (C syntax, INI syntax). For some files like C or C, this tree structure is quite flat. It looks much like a rake than a tree, but still, it's a tree. For instance, this C: $pdiffs 1 $max_wait 14 debian http://ftp.fr.debian.org/debian can have this tree representation: root |--pdiff=1 |--max_wait=14 `--distrib(debian)=http://ftp.fr.debian.org/debian Other configuration files like C or C have a structure that look more like a tree. For instance, consider this C snippet: Section "Device" Identifier "Device0" Driver "nvidia" EndSection Section "Screen" Identifier "Screen0" Device "Device0" Option "AllowGLXWithComposite" "True" Option "DynamicTwinView" "True" SubSection "Display" Depth 24 EndSubSection EndSection Knowing that Xorg.conf can have several Device or Screen sections identified by their C, the configuration can be represented in this tree as: root |--Device(Device0) | `--Driver=nvidia `--Screen(Screen0) |--Device=Device0 |--Option | |--AllowGLXWithComposite=True | `--DynamicTwinView=True `--Display `--Depth=24 One may argue that some C parameter refer to others (i.e.C and C value in C section) and so they cannot be represented as a tree. That's right, there are some more complex relations that are added to the tree structure. This will be covered in more details when dealing with complex models. In some other case, the structure of a tree is not fixed. For instance, C options in C are different depending on the value of the C. In this case, the structure of the configuration tree must be adapted (morphed) depending on a parameter value. Just like XML data can have Schema to validate their content, the configuration tree structure needs to have its own schema to validate its content. Since the tree structure cannot be represented as a static tree without reference, XML like schema are not enough to validate configuration data. L provides a kind of schema for configuration data that takes care of the cross references mentioned above and of the dynamic nature of the configuration tree required for C (and others). =head1 What is a model? A configuration model defines the configuration tree structure: =over =item * A model defines one or more configuration class =item * At least one class is required to define the configuration tree root =item * Each class contains several elements. An element can be: =over =item * A leaf to represent one configuration parameter =item * A list of hash of leaves to represent several parameter =item * A node to hold a node of a configuration tree =item * A list or hash of nodes =back =back These basic relations enable to define the main parts of a configuration tree. If we refer to the C example mentioned above, one only class is required (let's say the C class). This class must contain (see approx.conf man page): =over =item * A boolean leaf for C (1 if not specified) =item * An integer leaf for C (10 seconds unless specified otherwise) =item * A hash of string leaves for C (no default). =back A configuration model is stored this way by Config::Model: { name => 'Approx', element => [ pdiffs => { type => 'leaf', value_type => 'boolean', upstream_default => '1' }, max_wait => { type => 'leaf', value_type => 'integer', upstream_default => '10' }, distributions'=> { type => 'hash', index_type => 'string' , cargo => { value_type => 'uniline', type => 'leaf', }, } ] } The C example leads to a slightly more complex model with several classes: =over =item * C (root class) =item * C =item * C =item * C for the Screen options =item * C for theC subsection =back The root class is declared this way: { name => 'Xorg', element => [ Device => { type => 'hash', index_type => 'string' cargo => { type => 'node', config_class_name => 'Xorg::Device' }, }, Screen => { type => 'hash', index_type => 'string' cargo => { type => 'node', config_class_name => 'Xorg::Screen' }, }, ] } TheC class is: { name => 'Xorg::Screen', element => [ Device => { type' => 'leaf', value_type => 'uniline', }, Display => { type => 'hash', index_type => 'integer' cargo => { type => 'node', config_class_name => 'Xorg::Screen::Display' }, } Option => { type => 'node', config_class_name => 'Xorg::Screen::Option' }, ] } It's now time to detail how the elements of a class are constructed. =head1 Model analysis To define the required configuration classes, you should read the documentation of the target application to : =over =item * Find the structure of the configuration tree =item * Identify configuration parameters, their constraints and relations =back Last but not least, you should also find several valid examples of your application configuration. These examples can be used as non-regression tests and to verify that the application documentation was understood. =head1 Model declaration =head2 Configuration class declaration Since writing the data structure shown below is not fun (even with Perl), you are encouraged to use the model editor provided by L using C command (provided by L). This commands provides a GUI to create or update your model. When saving, C writes the data structure in the correct directory. =head2 Configuration class declaration (the hard way) In summary, configuration documentation is translated in a format usable by Config::Model: =over =item * The structure is translated into configuration classes =item * Configuration parameters are translated into elements =item * Constraints are translated into element attributes =back All models files must be written in a specific directory. For instance, for model C, you must create C<./lib/Config/Model/models/Xorg.pl>. Other classes like C can be stored in their own file C<./lib/Config/Model/models/Xorg/Screen.pl> or included in C A model file is a Perl file containing an array for hash ref. Each Hash ref contains a class declaration: [ { name => 'Xorg', ... } , { name => 'Xorg::Screen', ... } ] ; A class can have the following parameters: =over =item * name: mandatory name of the class =item * class_description: Description of the configuration class. =item * generated_by: Mention with a descriptive string if this class was generated by a program. This parameter is currently reserved for C model editor. =item * include: Include element description from another class. =back For more details, see L. For instance: $ cat lib/Config/Model/models/Xorg.pl [ { name => 'Xorg', class_description => 'Top level Xorg configuration.', include => [ 'Xorg::ConfigDir'], element => [ Files => { type => 'node', description => 'File pathnames', config_class_name => 'Xorg::Files' }, # snip ] }, { name => 'Xorg::DRI', element => [ Mode => { type => 'leaf', value_type => 'uniline', description => 'DRI mode, usually set to 0666' } ] } ]; =head2 Common attributes for all elements This first set of attributes helps the user by providing guidance (with C and C) and documentation (C and C). All elements (simple or complex) can have the following attributes: =over =item * C: full length description of the attribute =item * C: one line summary of the above description =item * C: is C, C or C. The level is used to set how configuration data is presented to the user in browsing mode. Important elements are shown to the user no matter what. hidden elements are explained with the warp notion. =item * C: is C, C or C (default). Warnings are shown when using a deprecated element and an exception is raised when an obsolete element is used. =back See L for details. =head2 Leaf elements Leaf element is the most common type to represent configuration data. A leaf element represents a specific configuration parameter. In more details, a leaf element have the following attributes (See L doc): =over =item type Set to C (mandatory) =item value_type Either C, C, C, C, C, C (i.e. a string without "\n") (mandatory) =item min Minimum value (for C or C) =item max Maximum value (for C or C) =item choice Possible values for an enum =item mandatory Whether the value is mandatory or not =item default Default value that must be written in the configuration file =item upstream_default Default value that is known by the target application and thus does not need to be written in the configuration file. =back To know which attributes to use, you should read the documentation of the target application. For instance, C parameter (sshd_config(5)) is specified with: I For Config::Model, C is a type C element, value_type C and the application falls back to C if this parameter is left blank in C file. Thus the model of this element is : AddressFamily => { type => 'leaf', value_type => 'enum', upstream_default => 'any', description => 'Specifies which address family should be used by sshd(8).', choice => [ 'any', 'inet', 'inet6' ] } =head2 Simple list or hash element Some configuration parameters are in fact a list or a hash of parameters. For instance, C can feature a list of remote repositories: # remote repositories debian http://ftp.fr.debian.org/debian multimedia http://www.debian-multimedia.org These repositorie URLs must be stored as a hash where the key is I or I and the associated value is a URL. But this hash must have something which is not explicit in C file: a parameter name. Approx man page mentions that: I. So let's use C as a parameter name. The example is stored this way in the configuration tree: root |--distribution(debian)=http://ftp.fr.debian.org/debian `--distribution(multimedia)=http://www.debian-multimedia.org The model needs to declare that C is: =over =item * a type C parameter =item * the hash key is a string =item * the values of the hash are of type C and value_type C =back distribution => { type => 'hash', index_type => 'string', cargo => { type => 'leaf', value_type => 'uniline', }, summary => 'remote repositories', description => 'The other name/value pairs are ...', } For more details on list and hash elements, see L man page. =head2 node element A node element is necessary if the configuration file has more than a list of variable. In this case, the tree is deeper than a rake and a node element if necessary to provide a new node within the tree. In the Xorg example above, the options of C need their own sub-branch in the tree: Screen(Screen0) `--Option |--AllowGLXWithComposite=True `--DynamicTwinView=True For this, a new dedicated class is necessary>Xorg::Screen::Option> (see its declaration above). This new class must be tied to the Screen class with a node element. A node element has the following parameters: =over =item * type (set to C) =item * the name of the configuration class name (>config_class_name>) =back So the C. 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 Computes 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 is 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 is matched 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 a default warning message) and instructions to fix the value. A warning is issued when the value matches the passed regular expression. Valid only for C or C values. The fix instructions is evaluated when L is called. C<$_> contains the value to fix. C<$_> is stored as the new value once the instructions are done. C<$self> contains the value object. Use with care. In the example below, any value matching 'foo' is converted in uppercase: warn_if_match => { 'foo' => { fix => 'uc;', msg => 'value $_ contains foo' }, 'BAR' => { fix =>'lc;', msg => 'value $_ contains BAR' } }, The tests are done in alphabetical order. In the example above, C test is done before C test. C<$_> is substituted with the bad value when the message is generated. C<$std_value> is substituted with the standard value (i.e the preset, computed or default value). =item warn_unless_match Hash ref like above. A warning is 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 is issued if the given code returns true. C<$_> contains the value to check. C<$self> contains the C object (use with care). The example below warns if value contains a number: warn_if => { warn_test => { code => 'defined $_ && /\d/;', msg => 'value $_ should not have numbers', fix => 's/\d//g;' } }, Hash key is used in warning message when C is not set: warn_if => { 'should begin with foo' => { code => 'defined && /^foo/' } } Any operation or check on file must be done with C sub (otherwise tests will break). This sub returns a L object that can be used to perform checks. For instance: warn_if => { warn_test => { code => 'not file($_)->exists', msg => 'file $_ should exist' } =item warn_unless Like C, but issue a warning when the given C returns false. The example below warns unless the value points to an existing directory: warn_unless => { 'missing dir' => { code => '-d', fix => "system(mkdir $_);" } } =item assert Like C. Except that returned value triggers an error when the given code returns false: assert => { test_nb => { code => 'defined $_ && /\d/;', msg => 'should not have numbers', fix => 's/\d//g;' } }, hash key can also be used to generate error message when C parameter is not set. =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 is modified to add "check" rule and this rules is set up 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' is 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 must 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 is replaced by C when 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'"} The key of help is used as a regular expression to find the help text applicable to a value. These regexp are tried from the longest to the shortest and are matched from the beginning of the string. The key "C<.>" or "C<.*>" are fallback used last. For instance: help => { 'foobar' => 'help for values matching /^foobar/', 'foo' => 'help for values matching /^foo/ but not /^foobar/ (used above)', '.' => 'help for all other values' } =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, and empty string. 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 is issued if the file does not exists (or is a directory) =item C A directory name or path. A warning is 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 means 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 loops are not detected and end up in "deep recursion subroutine" failures. =item * avoid "diamond" shaped warp dependencies: the results depends on the order of the warp algorithm which can be unpredictable in this case =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 is silently ignored during start up and fails 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 With a parameter, returns the help string applicable to the passed value or undef. Without parameter returns a hash ref that contains all the help strings. =head2 get_info Returns a list of information related to the value, like value type, default value. This should be used to provide some debug information to the user. For instance, C<$val->get-info> may return: [ 'type: string', 'mandatory: yes' ] =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 Parameters: C<< ( value ) >> Check the consistency of the value. C also accepts named parameters: =over 4 =item value =item quiet When non null, check does 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 Parameters: C<< ( [ value => foo ] ) >> Like L. Also displays 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 checks the value currently stored. =head2 is_bad_mode Accept a mode parameter. This function checks if the mode is accepted by L method. Returns an error message if not. For instance: if (my $err = $val->is_bad_mode('foo')) { croak "my_function: $err"; } This method is intented as a helper to avoid duplicating the list of accepted modes for functions that want to wrap fetch methods (like L or L) =head1 Information management =head2 store Parameters: C<< ( $value ) >> or C<< value => ..., check => yes|no|skip ), silent => 0|1 >> Store value in leaf element. C parameter can be used to skip validation check (default is 'yes'). C can be used to suppress warnings. Optional C is now deprecated. =head2 clear Clear the stored value. Further read returns the default value (or computed or migrated value). =head2 load_data Parameters: C<< ( $value ) >> Called with the same parameters are C method. Load scalar data. Data is forwarded to L after checking that the passed value is not a reference. =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 has_data Return true if the value contains information different from default or upstream 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 returns 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 is 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 is 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. Returns 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 With this mode, C behaves like in C mode, but returns C for mandatory values. Normally, trying to fetch an undefined mandatory value leads to an exception. =back =head2 fetch_summary Returns a truncated value when the value is a string or uniline that is too long to be displayed. =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 is triggered when 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-2022 by Dominique Dumont. This is free software, licensed under: The GNU Lesser General Public License, Version 2.1, February 1999 =cut Config-Model-2.149/lib/Config/Model/AnyId.pm0000644000175000017500000013431014170053137017016 0ustar domidomi# # This file is part of Config-Model # # This software is Copyright (c) 2005-2022 by Dominique Dumont. # # This is free software, licensed under: # # The GNU Lesser General Public License, Version 2.1, February 1999 # package Config::Model::AnyId 2.149; use 5.020; use Mouse; with "Config::Model::Role::NodeLoader"; with "Config::Model::Role::Utils"; use Config::Model::Exception; use Config::Model::Warper; use Carp qw/cluck croak carp/; use Log::Log4perl qw(get_logger :levels); use Storable qw/dclone/; use Mouse::Util::TypeConstraints; use Scalar::Util qw/weaken/; extends qw/Config::Model::AnyThing/; use feature qw/signatures postderef/; no warnings qw/experimental::signatures experimental::postderef/; subtype 'KeyArray' => as 'ArrayRef' ; coerce 'KeyArray' => from 'Str' => via { [$_] } ; my $logger = get_logger("Tree::Element::Id"); my $user_logger = get_logger("User"); my $deep_check_logger = get_logger('DeepCheck'); my $fix_logger = get_logger("Anything::Fix"); my $change_logger = get_logger("ChangeTracker"); enum 'DataMode' => [qw/preset layered normal/]; has data_mode => ( is => 'rw', isa => 'HashRef[DataMode]', traits => ['Hash'], handles => { get_data_mode => 'get', set_data_mode => 'set', delete_data_mode => 'delete', clear_data_mode => 'clear', }, default => sub { {}; } ); # this is cleared and set by set_properties has _warpable_check_content_actions => ( is => 'bare', # no direct accessor isa => 'ArrayRef[CodeRef]', traits => ['Array'], handles => { add_warpable_check_content => 'push', clear_warpable_check_content => 'clear', get_all_warpable_content_checks => 'elements', }, default => sub { []; } ); has _check_content_actions => ( is => 'bare', # no direct accessor isa => 'ArrayRef[CodeRef]', traits => ['Array'], handles => { add_check_content => 'push', get_all_content_checks => 'elements', }, default => sub { []; } ); # needs_content_check defaults to 1 to trap bad data right after loading has needs_content_check => ( is => 'rw', isa => 'Bool', default => 1 ); has has_fixes => ( is => 'ro', isa => 'Num', default => 0, traits => ['Number'], handles => { inc_fixes => [ add => 1 ], dec_fixes => [ sub => 1 ], add_fixes => 'add', flush_fixes => [ mul => 0 ], } ); # Some idea for improvement # suggest => 'foo' or '$bar foo' # creates a method analog to next_id (or next_id but I need to change # run_user_command) that suggest the next id as foo_ where # nb is incremented each time, or compute the passed formula # and performs the same my @common_int_params = qw/min_index max_index max_nb auto_create_ids/; has \@common_int_params => ( is => 'ro', isa => 'Maybe[Int]' ); my @common_hash_params = qw/default_with_init/; has \@common_hash_params => ( is => 'ro', isa => 'Maybe[HashRef]' ); my @common_list_params = qw/allow_keys default_keys auto_create_keys/; has \@common_list_params => ( is => 'ro', isa => 'KeyArray', coerce => 1, default => sub { []; } ); my @common_str_params = qw/allow_keys_from allow_keys_matching follow_keys_from migrate_keys_from migrate_values_from duplicates warn_if_key_match warn_unless_key_match/; has \@common_str_params => ( is => 'ro', isa => 'Maybe[Str]' ); my @common_params = ( @common_int_params, @common_str_params, @common_list_params, @common_hash_params ); my @allowed_warp_params = ( @common_params, qw/level convert/ ); around BUILDARGS => sub { my $orig = shift; my $class = shift; my %args = @_; my %h = map { ( $_ => $args{$_} ); } grep { defined $args{$_} } @allowed_warp_params; return $class->$orig( backup => dclone( \%h ), @_ ); }; has [qw/backup cargo/] => ( is => 'ro', isa => 'HashRef', required => 1 ); has warp => ( is => 'ro', isa => 'Maybe[HashRef]' ); has [qw/morph/] => ( is => 'ro', isa => 'Bool', default => 0 ); has content_warning_list => ( is => 'rw', isa => 'ArrayRef', default => sub { []; } ); has [qw/cargo_class max_index index_class index_type/] => ( is => 'rw', isa => 'Maybe[Str]' ); has config_model => ( is => 'ro', isa => 'Config::Model', weak_ref => 1, lazy => 1, builder => '_config_model' ); sub _config_model { my $self = shift; return $self->instance->config_model; } sub config_class_name { my $self = shift; return $self->cargo->{config_class_name}; } sub BUILD { my $self = shift; croak "Missing cargo->type parameter for element " . $self->{element_name} || 'unknown' unless defined $self->cargo->{type}; if ( $self->cargo->{type} eq 'node' and not $self->cargo->{config_class_name} ) { croak "Missing cargo->config_class_name parameter for element " . $self->element_name || 'unknown'; } if ( $self->{cargo}{type} eq 'hash' or $self->{cargo}{type} eq 'list' ) { die "$self->{element_name}: using $self->{cargo}{type} will probably not work"; } $self->set_properties(); if ( defined $self->warp ) { $self->{warper} = Config::Model::Warper->new( warped_object => $self, %{ $self->warp }, allowed => \@allowed_warp_params ); } return $self; } # this method can be called by the warp mechanism to alter (warp) the # feature of the Id object. sub set_properties ($self, @args) { # mega cleanup for ( @allowed_warp_params ) { delete $self->{$_}; } my %args = ( %{ $self->{backup} }, @args ); # these are handled by Node or Warper for ( qw/level/ ) { delete $args{$_}; } $logger->trace( $self->name, " set_properties called with @args" ); for ( @common_params ) { $self->{$_} = delete $args{$_} if defined $args{$_}; } $self->set_convert( \%args ) if defined $args{convert}; $self-> clear_warpable_check_content; for ( $self-> get_all_content_checks ) { $self-> add_warpable_check_content($_); } for ( qw/duplicates/ ) { my $method = "check_$_"; my $weak_self = $self; weaken($weak_self); # weaken reference loop ($self - check_content - closure - self) $self-> add_check_content( sub { $weak_self->$method(@_);} ) if $self->{$_}; } Config::Model::Exception::Model->throw( object => $self, error => "Undefined index_type" ) unless defined $self->{index_type}; Config::Model::Exception::Model->throw( object => $self, error => "Unexpected index_type $self->{index_type}" ) unless ( $self->{index_type} eq 'integer' or $self->{index_type} eq 'string' ); my @current_idx = $self->_fetch_all_indexes(); if (@current_idx) { my $first_idx = shift @current_idx; my $last_idx = pop @current_idx; foreach my $idx ( ( $first_idx, $last_idx ) ) { my $ok = $self->check_idx($first_idx); next if $ok; # here a user input may trigger an exception even if fetch # or set value check is disabled. That's mostly because, # we cannot enforce more strict settings without random # deletion of data. For instance, if a hash contains 5 # items and the max_nb of items is reduced to 3. Which 2 # items should we remove ? # Since we cannot choose, we must raise an exception in # all cases. Config::Model::Exception::WrongValue->throw( error => "Error while setting id property:" . join( "\n\t", @{ $self->{idx_error_list} } ), object => $self ); } } $self->auto_create_elements; if ( defined $self->{duplicates} and defined $self->{cargo} and $self->{cargo}{type} ne 'leaf' ) { Config::Model::Exception::Model->throw( object => $self, error => "Cannot specify 'duplicates' with cargo type '$self->{cargo}{type}'", ); } my $ok_dup = 'forbid|suppress|warn|allow'; if ( defined $self->{duplicates} and $self->{duplicates} !~ /^$ok_dup$/ ) { Config::Model::Exception::Model->throw( object => $self, error => "Unexpected 'duplicates' $self->{duplicates} expected $ok_dup", ); } Config::Model::Exception::Model->throw( object => $self, error => "Unexpected parameters: " . join( ' ', keys %args ) ) if scalar keys %args; return; } sub create_default_with_init { my $self = shift; my $idx = shift; return unless defined $self->{default_with_init}; my $h = $self->{default_with_init}; foreach my $def_key ( keys %$h ) { $self->create_default_content($def_key); } return; } sub create_default_content { my $self = shift; my $idx = shift // die "missing index"; return unless defined $self->{default_with_init}; my $def = $self->{default_with_init}{$idx}; return unless defined $def; # no default content to create for $idx return if $self->_defined($idx) ; # object already created $self->auto_vivify($idx); my $v_obj = $self->_fetch_with_id($idx); if ( $v_obj->get_type eq 'leaf' ) { $v_obj->store( $def ); } else { $v_obj->load( $def ); } return; } sub max { my $self = shift; carp $self->name, ": max param is deprecated, use max_index\n"; return $self->max_index; } sub min { my $self = shift; carp $self->name, ": min param is deprecated, use min_index\n"; return $self->min_index; } sub cargo_type { goto &get_cargo_type; } sub get_cargo_type { my $self = shift; #my @ids = $self->fetch_all_indexes ; # the returned cargo type might be different from collected type # when collected type is 'warped_node'. #return @ids ? $self->fetch_with_id($ids[0])->get_cargo_type # : $self->{cargo_type} ; return $self->{cargo}{type}; } sub get_cargo_info { my $self = shift; my $what = shift; return $self->{cargo}{$what}; } # internal, does a grab with improved error message sub safe_typed_grab ($self, %args) { my $param = $args{param} || croak "safe_typed_grab: missing param"; my $res = eval { $self->grab( step => $self->{$param}, type => $self->get_type, check => $args{check} || 'yes', ); }; if ($@) { my $e = $@; my $msg = $e ? $e->full_message : ''; Config::Model::Exception::Model->throw( object => $self, error => "'$param' parameter: " . $msg ); } return $res; } sub get_default_keys { my $self = shift; if ( $self->{follow_keys_from} ) { my $followed = $self->safe_typed_grab( param => 'follow_keys_from' ); my @res = $followed->fetch_all_indexes; return wantarray ? @res : \@res; } my @res; push @res, @{ $self->{default_keys} } if defined $self->{default_keys}; push @res, keys %{ $self->{default_with_init} } if defined $self->{default_with_init}; return wantarray ? @res : \@res; } sub name { my $self = shift; return $self->{parent}->name . ' ' . $self->{element_name} . ' id'; } # internal. Handle model declaration arguments sub handle_args ($self, %args) { my $warp_info = delete $args{warp}; for (qw/index_class index_type morph ordered/) { $self->{$_} = delete $args{$_} if defined $args{$_}; } $self->{backup} = dclone( \%args ); $self->set_properties(%args) if defined $self->{index_type}; if ( defined $warp_info ) { $self->{warper} = Config::Model::Warper->new( warped_object => $self, %$warp_info, allowed => \@allowed_warp_params ); } return $self; } sub apply_fixes { my $self = shift; $fix_logger->trace( $self->location . ": apply_fixes called" ); $self->deep_check( fix => 1, logger => $fix_logger ); return; } my %check_idx_dispatch = map { ( $_ => 'check_' . $_ ); } qw/follow_keys_from allow_keys allow_keys_from allow_keys_matching warn_if_key_match warn_unless_key_match/; my %mode_move = ( layered => { preset => 1, normal => 1 }, preset => { normal => 1 }, normal => {}, ); around notify_change => sub ($orig, $self, %args) { if ($change_logger->is_trace) { my @a = map { ( $_ => $args{$_} // '' ); } sort keys %args; $change_logger->trace( "called for ", $self->name, " from ", join( ' ', caller ), " with ", join( ' ', @a ) ); } # $idx may be undef if $self has changed, not necessarily its content my $idx = $args{index}; if ( defined $idx ) { # use $idx to trigger move from layered->preset->normal my $imode = $self->instance->get_data_mode; my $old_mode = $self->get_data_mode($idx) || 'normal'; $self->set_data_mode( $idx, $imode ) if $mode_move{$old_mode}{$imode}; } return if $self->instance->initial_load and not $args{really}; $self-> needs_content_check(1); $self->$orig(%args); return; }; # the number of checks is becoming confusing. We have # - check_idx to check whether an index is fine. This is called when creating # a new index # - check_content: a more expensive check that runs all content checker registered # in this object. By default, none. A plain AnyId can contains a duplicated_content # checker if configured # - a deep_check (for lack of a better name): a also expensive check that involve index # versus other part of the config tree. By default, no check is done. This is currently # used only by DPkg model which check if the index value is used elsewhere # Using plain check in this class is avoided because it's too generic, but a polymorphic # entry point is still needed, oh well... sub check { # since check is not used when creating an index, but called explicitly # so it can be forwarded to deep_check. goto &deep_check; # backward compat } sub deep_check ($self, @args) { $deep_check_logger->trace("called on ".$self->name); for ( $self->fetch_all_indexes() ) { $self->check_idx(@args, index => $_); } $self->check_content(@args, logger => $deep_check_logger); return; } # check globally the list or hash, called by apply_fix or deep_check sub check_content ($self, %args) { my $silent = $args{silent} || 0; my $apply_fix = $args{fix} || 0; my $local_logger = $args{logger} || $logger; if ( $self-> needs_content_check ) { $local_logger->trace( "Running check_content on ",$self->location ); # need to keep track to update GUI $self-> flush_fixes; # reset before check my @error; my @warn; foreach my $sub ( $self-> get_all_content_checks ) { $sub->( \@error, \@warn, $apply_fix, $silent ); } my $nb = $self->fetch_size; push @error, "Too many items ($nb) limit $self->{max_nb}, " if defined $self->{max_nb} and $nb > $self->{max_nb}; if (not $silent) { for ( @warn ) { $user_logger->warn( "Warning in '" . $self->location_short . "': $_" ) } } $self->{content_warning_list} = \@warn; $self->{content_error_list} = \@error; $self-> needs_content_check(0); return scalar @error ? 0 : 1; } else { $local_logger->debug( $self->location, " has not changed, actual check skipped" ) if $local_logger->is_debug; my $err = $self->{content_error_list} // []; return scalar @$err ? 0 : 1; } } # internal function to check the validity of the index. Called when creating a new # index or when set_properties is called (init or during warp) sub check_idx ($self, @args) { my %args = _resolve_arg_shortcut(\@args, 'index'); my $idx = $args{index}; my $silent = $args{silent} || 0; my $check = $args{check} || 'yes'; my $apply_fix = $args{fix} // ($check eq 'fix' ? 1 : 0); Config::Model::Exception::Internal->throw( object => $self, error => "check_idx method: key or index is not defined" ) unless defined $idx; my @error; my @warn; foreach my $key_check_name ( keys %check_idx_dispatch ) { next unless $self->{$key_check_name}; my $method = $check_idx_dispatch{$key_check_name}; $self->$method( $idx, \@error, \@warn, $apply_fix ); } my $nb = $self->fetch_size; my $new_nb = $nb; $new_nb++ unless $self->_exists($idx); if ( $idx eq '' ) { push @error, "Index is empty"; } elsif ( $self->{index_type} eq 'integer' and $idx =~ /\D/ ) { push @error, "Index is not integer ($idx)"; } elsif ( defined $self->{max_index} and $idx > $self->{max_index} ) { push @error, "Index $idx > max_index limit $self->{max_index}"; } elsif ( defined $self->{min_index} and $idx < $self->{min_index} ) { push @error, "Index $idx < min_index limit $self->{min_index}"; } push @error, "Too many items ($new_nb) limit $self->{max_nb}, " . "rejected id '$idx'" if defined $self->{max_nb} and $new_nb > $self->{max_nb}; if ( scalar @error ) { my @a = $self->_fetch_all_indexes; push @error, "Item ids are '" . join( ',', @a ) . "'", $self->warp_error; } $self->{idx_error_list} = \@error; $self->{warning_hash}{$idx} = \@warn; if (@warn and not $silent and $check ne 'no') { for (@warn) { $user_logger->warn( "Warning in '" . $self->location_short . "': $_" ); } } return scalar @error ? 0 : 1; } #internal sub check_follow_keys_from { my ( $self, $idx, $error ) = @_; my $followed = $self->safe_typed_grab( param => 'follow_keys_from' ); return if $followed->exists($idx); push @$error, "key '" . $self->shorten_idx($idx) . "' does not exists in followed object '" . $followed->name . "'. Expected '" . join( "', '", $followed->fetch_all_indexes ) . "'"; return; } #internal sub check_allow_keys { my ( $self, $idx, $error ) = @_; my $ok = grep { $_ eq $idx } @{ $self->{allow_keys} }; push @$error, "Unexpected key '" . $self->shorten_idx($idx) . "'. Expected '" . join( "', '", @{ $self->{allow_keys} } ) . "'" unless $ok; return; } #internal sub check_allow_keys_matching { my ( $self, $idx, $error ) = @_; my $match = $self->{allow_keys_matching}; push @$error, "Unexpected key '" . $self->shorten_idx($idx) . "'. Key must match $match" unless $idx =~ /$match/; return; } #internal sub check_allow_keys_from { my ( $self, $idx, $error ) = @_; my $from = $self->safe_typed_grab( param => 'allow_keys_from' ); my $ok = grep { $_ eq $idx } $from->fetch_all_indexes; return if $ok; push @$error, "key '" . $self->shorten_idx($idx) . "' does not exists in '" . $from->name . "'. Expected '" . join( "', '", $from->fetch_all_indexes ) . "'"; return; } sub check_warn_if_key_match { my ( $self, $idx, $error, $warn ) = @_; my $re = $self->{warn_if_key_match}; push @$warn, "key '" . $self->shorten_idx($idx) . "' should not match $re\n" if $idx =~ /$re/; return; } sub check_warn_unless_key_match { my ( $self, $idx, $error, $warn ) = @_; my $re = $self->{warn_unless_key_match}; push @$warn, "key '" . $self->shorten_idx($idx) . "' should match $re\n" unless $idx =~ /$re/; return; } sub check_duplicates { my ( $self, $error, $warn, $apply_fix, $silent ) = @_; my $dup = $self->{duplicates}; return if $dup eq 'allow'; $logger->trace("check_duplicates called"); my %h; my @issues; my @to_delete; foreach my $i ( $self->fetch_all_indexes ) { my $v = $self->fetch_with_id( index => $i, check => 'no' )->fetch; next unless $v; $h{$v} = 0 unless defined $h{$v}; $h{$v}++; if ( $h{$v} > 1 ) { $logger->debug("got duplicates $i -> $v : $h{$v}"); push @to_delete, $i; push @issues, qq!$i:"$v"!; } } return unless @issues; if ($apply_fix) { $logger->debug("Fixing duplicates @issues, removing @to_delete"); for (reverse @to_delete) { $self->remove($_) } } elsif ( $dup eq 'forbid' ) { $logger->debug("Found forbidden duplicates @issues"); push @$error, "Forbidden duplicates value @issues"; } elsif ( $dup eq 'warn' ) { $logger->debug("warning condition: found duplicate @issues"); push @$warn, "Duplicated value: @issues"; $self->add_fixes( scalar @issues); } elsif ( $dup eq 'suppress' ) { $logger->debug("suppressing duplicates @issues"); for (reverse @to_delete) { $self->remove($_) } } else { die "Internal error: duplicates is $dup"; } return; } sub fetch_with_id ($self, @args) { my %args = _resolve_arg_shortcut(\@args, 'index'); my $check = $self->_check_check( $args{check} ); my $idx = $args{index}; $logger->trace( $self->name, " called for idx $idx" ) if $logger->is_trace; $idx = $self->{convert_sub}($idx) if ( defined $self->{convert_sub} and defined $idx ); # try migration only once $self->_migrate unless $self->{migration_done}; my $ok = 1; # check index only if it's unknown $ok = $self->check_idx( index => $idx, check => $check ) unless $self->_defined($idx) or $check eq 'no'; if ( $ok or $check eq 'no' ) { # create another method $self->create_default_content($idx); # no-op if idx exists $self->auto_vivify($idx) unless $self->_defined($idx); return $self->_fetch_with_id($idx); } else { Config::Model::Exception::WrongValue->throw( error => join( "\n\t", @{ $self->{idx_error_list} } ), object => $self ); } return; } sub get ($self, @args) { my %args = _resolve_arg_shortcut(\@args, 'path'); my $path = delete $args{path}; my $autoadd = 1; $autoadd = $args{autoadd} if defined $args{autoadd}; my $get_obj = delete $args{get_obj} || 0; $path =~ s!^/!!; my ( $item, $new_path ) = split m!/!, $path, 2; my $dcm = $args{dir_char_mockup}; # $item =~ s($dcm)(/)g if $dcm ; if ($dcm) { while (1) { my $i = index( $item, $dcm ); last if $i == -1; substr $item, $i, length($dcm), '/'; } } return unless ( $self->exists($item) or $autoadd ); $logger->trace("get: path $path, item $item"); my $obj = $self->fetch_with_id( index => $item, %args ); return $obj if ( ( $get_obj or $obj->get_type ne 'leaf' ) and not defined $new_path ); return $obj->get( path => $new_path, get_obj => $get_obj, %args ); } sub set ($self, $path, @args) { $path =~ s!^/!!; my ( $item, $new_path ) = split m!/!, $path, 2; return $self->fetch_with_id($item)->set( $new_path, @args ); } sub copy { 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" ); return $self->fetch_with_id($to)->store( $from_obj->fetch() ); } elsif ($ok) { # node object $logger->trace( "AnyId: deep copy node from " . $self->name ); my $target = $self->fetch_with_id($to); $logger->trace( "AnyId: deep copy node to " . $target->name ); return $target->copy_from($from_obj); } else { Config::Model::Exception::WrongValue->throw( error => join( "\n\t", @{ $self->{idx_error_list} } ), object => $self ); } return; } sub fetch_all { my $self = shift; my @keys = $self->fetch_all_indexes; return map { $self->fetch_with_id($_); } @keys; } sub fetch ($self, @args) { return join(',', $self->fetch_all_values(@args) ); } sub fetch_value ($self, @args) { my %args = _resolve_arg_shortcut(\@args, 'idx'); return $self->_fetch_value(%args, sub => 'fetch'); } sub fetch_summary ($self, @args) { my %args = _resolve_arg_shortcut(\@args, 'idx'); return $self->_fetch_value(%args, sub => 'fetch_summary'); } sub _fetch_value ($self, %args) { my $check = $self->_check_check( $args{check} ); my $sub = delete $args{sub}; if ( $self->{cargo}{type} eq 'leaf' ) { return $self->fetch_with_id($args{idx})->$sub( check => $check, mode => $args{mode} ); } else { Config::Model::Exception::WrongType->throw( object => $self, function => 'fetch_values', got_type => $self->{cargo}{type}, expected_type => 'leaf', info => "with index $args{idx}", ); } return; } sub fetch_all_values ($self, @args) { my %args = _resolve_arg_shortcut(\@args, 'mode'); my $mode = $args{mode}; my $check = $self->_check_check( $args{check} ); my @keys = $self->fetch_all_indexes; # verify content restrictions applied to List (e.g. no duplicate values) my $ok = $check eq 'no' ? 1 : $self->check_content(); if ( $ok or $check eq 'no' ) { return grep { defined $_ } map { $self->fetch_value(idx => $_, check => $check, mode => $mode ); } @keys; } else { Config::Model::Exception::WrongValue->throw( error => join( "\n\t", @{ $self->{content_error_list} } ), object => $self ); } return; } sub fetch_all_indexes { my $self = shift; $self->create_default; # will check itself if creation is necessary $self->_migrate; return $self->_fetch_all_indexes; } sub get_all_indexes { my $self = shift; carp "get_all_indexes is deprecated. use fetch_all_indexes"; return $self->fetch_all_indexes; } sub children { my $self = shift; return $self->fetch_all_indexes; } sub has_data { my $self = shift; return $self->fetch_size ; } # auto vivify must create according to cargo}{type # node -> Node or user class # leaf -> Value or user class # warped node cannot be used. Same effect can be achieved by warping # cargo_args my %element_default_class = ( warped_node => 'WarpedNode', node => 'Node', leaf => 'Value', ); my %can_override_class = ( node => 0, leaf => 1, ); #internal sub auto_vivify { my ( $self, $idx ) = @_; my %cargo_args = %{ $self->cargo }; my $class = delete $cargo_args{class}; # to override class in cargo my $cargo_type = delete $cargo_args{type}; Config::Model::Exception::Model->throw( object => $self, message => "unknown '$cargo_type' cargo type: " . "in cargo_args. Expected " . join( ' or ', keys %element_default_class ) ) unless defined $element_default_class{$cargo_type}; my $el_class = 'Config::Model::' . $element_default_class{$cargo_type}; if ( defined $class ) { Config::Model::Exception::Model->throw( object => $self, message => "$cargo_type class " . "cannot be overidden by '$class'" ) unless $can_override_class{$cargo_type}; $el_class = $class; } my @common_args = ( element_name => $self->{element_name}, index_value => $idx, instance => $self->{instance}, parent => $self->parent, container => $self, %cargo_args, ); my $item; # check parameters passed by the user if ( $cargo_type eq 'node' ) { $item = $self->load_node( @common_args, config_class_name => $self->config_class_name ); } else { Mouse::Util::load_class($el_class); $item = $el_class->new(@common_args); } my $imode = $self->instance->get_data_mode; $self->set_data_mode( $idx, $imode ); $self->_store( $idx, $item ); return; } ## no critic (Subroutines::ProhibitBuiltinHomonyms) sub defined { my ( $self, $idx ) = @_; return $self->_defined($idx); } ## no critic (Subroutines::ProhibitBuiltinHomonyms) sub exists { my ( $self, $idx ) = @_; return $self->_exists($idx); } ## no critic (Subroutines::ProhibitBuiltinHomonyms) sub delete { my ( $self, $idx ) = @_; delete $self->{warning_hash}{$idx}; my $ret = $self->_delete($idx); # notification is not needed if the value was already delete or missing $self->notify_change( note => "deleted entry $idx" ) if defined $ret; return $ret; } sub clear { my ($self) = @_; $self->{warning_hash} = {}; $self->_clear; $self->clear_data_mode; $self->notify_change( note => "cleared all entries" ); return; } sub clear_values { my ($self) = @_; carp "clear_values deprecated"; my $ct = $self->get_cargo_type; Config::Model::Exception::User->throw( object => $self, message => "clear_values() called on non leaf cargo type: '$ct'" ) if $ct ne 'leaf'; # this will trigger a notify_change for ( $self->fetch_all_indexes ) { $self->fetch_with_id($_)->store(undef); } $self->notify_change( note => "cleared all values" ); return; } sub warning_msg { my ( $self, $idx ) = @_; my $list ; if ( defined $idx ) { $list = $self->{warning_hash}{$idx} ; } elsif ( @{ $self->{content_warning_list} } ) { $list = $self->{content_warning_list} ; } return $list ? join( "\n", @$list ) : ''; } sub has_warning { my $self = shift; return @{ $self->{content_warning_list} }; } sub error_msg { my $self = shift; my @list; for (qw/idx_error_list content_error_list/) { push @list, @{ $self->{$_} } if $self->{$_}; } return unless @list; return wantarray ? @list : join( "\n\t", @list ); } __PACKAGE__->meta->make_immutable; 1; # ABSTRACT: Base class for hash or list element __END__ =pod =encoding UTF-8 =head1 NAME Config::Model::AnyId - Base class for hash or list element =head1 VERSION version 2.149 =head1 SYNOPSIS use Config::Model; # define configuration tree object my $model = Config::Model->new; $model->create_config_class( name => "Foo", element => [ [qw/foo bar/] => { type => 'leaf', value_type => 'string' }, ] ); $model->create_config_class( name => "MyClass", element => [ plain_hash => { type => 'hash', index_type => 'string', cargo => { type => 'leaf', value_type => 'string', }, }, bounded_hash => { type => 'hash', # hash id index_type => 'integer', # hash boundaries min_index => 1, max_index => 123, max_nb => 2, # specify cargo held by hash cargo => { type => 'leaf', value_type => 'string' }, }, bounded_list => { type => 'list', # list id max_index => 123, cargo => { type => 'leaf', value_type => 'string' }, }, hash_of_nodes => { type => 'hash', # hash id index_type => 'string', cargo => { type => 'node', config_class_name => 'Foo' }, }, ], ); my $inst = $model->instance( root_class_name => 'MyClass' ); my $root = $inst->config_root; # put data my $steps = 'plain_hash:foo=boo bounded_list=foo,bar,baz bounded_hash:3=foo bounded_hash:30=baz hash_of_nodes:"foo node" foo="in foo node" - hash_of_nodes:"bar node" bar="in bar node" '; $root->load( steps => $steps ); # dump resulting tree print $root->dump_tree; =head1 DESCRIPTION This class provides hash or list elements for a L. The hash index can either be en enumerated type, a boolean, an integer or a string. =head1 CONSTRUCTOR AnyId object should not be created directly. =head1 Hash or list model declaration A hash or list element must be declared with the following parameters: =over =item type Mandatory element type. Must be C or C to have a collection element. The actual element type must be specified by C<< cargo => type >>. =item index_type Either C or C. Mandatory for hash. =item ordered Whether to keep the order of the hash keys (default no). (a bit like L). The hash keys are ordered along their creation. The order can be modified with L, L or L. =item duplicates Specify the policy regarding duplicated values stored in the list or as hash values (valid only when cargo type is C). The policy can be C (default), C, C (which offers the possibility to apply a fix), C. Note that duplicates I: this happens outside of this object. Duplicates can be check only after when the value is read. =item write_empty_value By default, hash entries without data are not saved in configuration files. Without data means the cargo of the hash key is empty: either its value is undef or all the values of the contained node are also empty. Set this parameter to 1 if the key must be saved in the configuration file even if the hash contains no value for that key. Note that writing hash entries without value may not be supported by all backends. Use with care. Supported only for hash elements. =item cargo Hash ref specifying the cargo held by the hash of list. This has must contain: =over 8 =item type Can be C or C (default). =item config_class_name Specifies the type of configuration object held in the hash. Only valid when C C is C. =item Constructor arguments passed to the cargo object. See L when C<< cargo->type >> is C. See L when C<< cargo->type >> is C. =back =item min_index Specify the minimum value (optional, only for hash and for integer index) =item max_index Specify the maximum value (optional, only for list or for hash with integer index) =item max_nb Specify the maximum number of indexes. (hash only, optional, may also be used with string index type) =item default_keys When set, the default parameter (or set of parameters) are used as default keys hashes and created automatically when the C or C functions are used on an I hash. You can use C<< default_keys => 'foo' >>, or C<< default_keys => ['foo', 'bar'] >>. =item default_with_init To perform special set-up on children nodes you can also use default_with_init => { foo => 'X=Av Y=Bv', bar => 'Y=Av Z=Cv' } When the hash contains leaves, you can also use: default_with_init => { def_1 => 'def_1 stuff', def_2 => 'def_2 stuff' } =item migrate_keys_from Specifies that the keys of the hash are copied from another hash in the configuration tree only when the hash is read for the first time after initial load (i.e. once the configuration files are completely read). migrate_keys_from => '- another_hash' =item migrate_values_from Specifies that the values of the hash (or list) are copied from another hash (or list) in the configuration tree only when the hash (or list) is read for the first time after initial load (i.e. once the configuration files are completely read). migrate_values_from => '- another_hash_or_list' =item follow_keys_from Specifies that the keys of the hash follow the keys of another hash in the configuration tree. In other words, the created hash always has the same keys as the other hash. follow_keys_from => '- another_hash' =item allow_keys Specifies authorized keys: allow_keys => ['foo','bar','baz'] =item allow_keys_from A bit like the C parameters. Except that the hash pointed to by C specified the authorized keys for this hash. allow_keys_from => '- another_hash' =item allow_keys_matching Keys must match the specified regular expression. For instance: allow_keys_matching => '^foo\d\d$' =item auto_create_keys When set, the default parameter (or set of parameters) are used as keys hashes and created automatically. (valid only for hash elements) Called with C<< auto_create_keys => ['foo'] >>, or C<< auto_create_keys => ['foo', 'bar'] >>. =item warn_if_key_match Issue a warning if the key matches the specified regular expression =item warn_unless_key_match Issue a warning unless the key matches the specified regular expression =item auto_create_ids Specifies the number of elements to create automatically. E.g. C<< auto_create_ids => 4 >> initializes the list with 4 undef elements. (valid only for list elements) =item convert => [uc | lc ] The hash key are converted to uppercase (uc) or lowercase (lc). =item warp See L below. =back =head1 Warp: dynamic value configuration The Warp functionality enables an L or L object to change its default settings (e.g. C, C or C parameters) dynamically according to the value of another C object. (See L for explanation on warp mechanism) For instance, with this model: $model ->create_config_class ( name => 'Root', 'element' => [ macro => { type => 'leaf', value_type => 'enum', name => 'macro', choice => [qw/A B C/], }, warped_hash => { type => 'hash', index_type => 'integer', max_nb => 3, warp => { follow => '- macro', rules => { A => { max_nb => 1 }, B => { max_nb => 2 } } }, cargo => { type => 'node', config_class_name => 'Dummy' } }, ] ); Setting C to C means that C can only accept one C class item . Setting C to C means that C accepts two C class items. Like other warped class, a HashId or ListId can have multiple warp masters (See L: warp => { follow => { m1 => '- macro1', m2 => '- macro2' }, rules => [ '$m1 eq "A" and $m2 eq "A2"' => { max_nb => 1}, '$m1 eq "A" and $m2 eq "B2"' => { max_nb => 2} ], } =head2 Warp and auto_create_ids or auto_create_keys When a warp is applied with C or C parameter, the auto_created items are created if they are not already present. But this warp never removes items that were previously auto created. For instance, when a tied hash is created with C<< auto_create => [a,b,c] >>, the hash contains C<(a,b,c)>. Then, once a warp with C<< auto_create_keys => [c,d,e] >> is applied, the hash then contains C<(a,b,c,d,e)>. The items created by the first auto_create_keys are not removed. =head2 Warp and max_nb When a warp is applied, the items that do not fit the constraint (e.g. min_index, max_index) are removed. For the max_nb constraint, an exception is raised if a warp leads to a number of items greater than the max_nb constraint. =head1 Content check By default, this class provides an optional content check that checks for duplicated values (when C parameter is set). Derived classes can register more global checker with the following method. =head2 add_check_content This method expects a sub ref with signature C<( $self, $error, $warn, $apply_fix )>. Where C<$error> and C<$warn> are array ref. You can push error or warning messages there. C<$apply_fix> is a boolean. When set to 1, the passed method can fix the warning or the error. Please make sure to weaken C<$self> to avoid memory cycles. Example: package MyId; use Mouse; extends qw/Config::Model::HashId/; use Scalar::Util qw/weaken/; sub setup { my $self = shift; weaken($self); $self-> add_check_content( sub { $self->check_usused_licenses(@_);} ) } =head1 Introspection methods The following methods returns the current value stored in the Id object (as declared in the model unless they were warped): =over =item min_index =item max_index =item max_nb =item index_type =item default_keys =item default_with_init =item follow_keys_from =item auto_create_ids =item auto_create_keys =item ordered =item morph =item config_model =back =head2 get_cargo_type Returns the object type contained by the hash or list (i.e. returns C<< cargo -> type >>). =head2 get_cargo_info Parameters: C<< ( < what > ) >> Returns more info on the cargo contained by the hash or list. C may be C or any other cargo info stored in the model. Returns undef if the requested info is not provided in the model. =head2 get_default_keys Returns a list (or a list ref) of the current default keys. These keys can be set by the C or C parameters or by the other hash pointed by C parameter. =head2 name Returns the object name. The name finishes with ' id'. =head2 config_class_name Returns the config_class_name of collected elements. Valid only for collection of nodes. This method returns undef if C C is not C. =head2 has_fixes Returns the number of fixes that can be applied to the current value. =head1 Information management =head2 fetch_with_id Parameters: C<< ( index => $idx , [ check => 'no' ]) >> Fetch the collected element held by the hash or list. Index check is 'yes' by default. Can be called with one parameter which is used as index. =head2 get Get a value from a directory like path. Parameters are: =over =item path Poor man's version of XPath style path. This string is in the form: /foo/bar/4 Each word between the '/' is either an element name or a hash key or a list index. =item mode Either C, C, C,... See C parameter in =item check Either C, C =item get_obj If the path leads to a leaf, this parameter tell whether to return the stored value or the value object. =item autoadd Whether to create missing keys =item dir_char_mockup When the hash key used contains '/', (for instance a directory value), the key cannot be used as is with this method. Because '/' is already used to separate configuration items (this is also important with L). This parameter specifies how the forbidden '/' char is shown in the path. Default is C<< >> =back =head2 set Parameters: C<( path, value )> Set a value with a directory like path. =head2 copy Parameters: C<( from_index, to_index )> Deep copy an element within the hash or list. If the element contained by the hash or list is a node, all configuration information is copied from one node to another. =head2 fetch_all Returns an array containing all elements held by the hash or list. =head2 fetch_value Parameters: C<< ( idx => ..., mode => ..., check => ...) >> Returns the value held by the C element of the hash or list. This method is only valid for hash or list containing leaves. See L for C argument documentation and L for C argument documentation. =head2 fetch_summary Arguments: C<< ( idx => ..., mode => ..., check => ...) >> Like L, but returns a truncated value when the value is a string or uniline that is too long to be displayed. =head2 fetch_all_values Parameters: C<< ( mode => ..., check => ...) >> Returns an array containing all defined values held by the hash or list. (undefined values are simply discarded). This method is only valid for hash or list containing leaves. With C parameter, this method returns either: =over =item custom The value entered by the user =item preset The value entered in preset mode =item standard The value entered in preset mode or checked by default. =item default The default value (defined by the configuration model) =back See L for C argument documentation. =head2 fetch Similar to L, with the same parameters, Returns the result as a string with comma separated list values. =head2 fetch_all_indexes Returns an array containing all indexes of the hash or list. Hash keys are sorted alphabetically, except for ordered hashed. =head2 children Like fetch_all_indexes. This method is polymorphic for all non-leaf objects of the configuration tree. =head2 defined Parameters: C<( index )> Returns true if the value held at C is defined. =head2 exists Parameters: C<( index )> Returns true if the value held at C exists (i.e the key exists but the value may be undefined). This method may not make sense for list element. =head2 has_data Return true if the array or hash is not empty. =head2 delete Parameters: C<( index )> Delete the Ced value =head2 clear Delete all values (also delete underlying value or node objects). =head2 clear_values Delete all values (without deleting underlying value objects). =head2 warning_msg Parameters: C<( [index] )> Returns warnings concerning indexes of this hash. Without parameter, returns a string containing all warnings or undef. With an index, return the warnings concerning this index or undef. =head2 has_warning Returns the current number of warning. =head2 error_msg Returns the error messages of this object (if any) =head1 AUTHOR Dominique Dumont, ddumont [AT] cpan [DOT] org =head1 SEE ALSO L, L, L, L, L, L, L, L =head1 AUTHOR Dominique Dumont =head1 COPYRIGHT AND LICENSE This software is Copyright (c) 2005-2022 by Dominique Dumont. This is free software, licensed under: The GNU Lesser General Public License, Version 2.1, February 1999 =cut Config-Model-2.149/lib/Config/Model/BackendTrackOrder.pm0000644000175000017500000001316414170053137021325 0ustar domidomi# # This file is part of Config-Model # # This software is Copyright (c) 2005-2022 by Dominique Dumont. # # This is free software, licensed under: # # The GNU Lesser General Public License, Version 2.1, February 1999 # package Config::Model::BackendTrackOrder 2.149; # ABSTRACT: Track read order of elements from configuration use Mouse; use strict; use warnings; use Carp; use 5.10.0; use Mouse::Util; use Log::Log4perl qw(get_logger :levels); my $logger = get_logger("BackendTrackOrder"); has backend_obj => ( is => 'ro', isa => 'Config::Model::Backend::Any', weak_ref => 1, required => 1, handles => [qw/node get_element_names/], ); has _creation_order => ( is => 'bare', isa => 'ArrayRef[Str]', traits => ['Array'], default => sub { [] }, handles => { _register_element => 'push', get_element_names_as_created => 'elements', _insert_element => 'insert', } ); has _created => ( is => 'rw', isa => 'HashRef[Str]', traits => ['Hash'], default => sub { {} }, handles => { register_created => 'set', has_created => 'exists', } ); # keeping order in Node does not make sense: one must read parameter # in canonical order to enable warp mechanism from one elemnet to the # other, so the read order will never differ from the canonical # order. Only some elements will be missing # What about default values, not created, no store done ???? # -> when writing back, mix all elements from canonical list into existing list ... # or at the end of initial load ??? # or mixall at the end of init() ? sub register_element { my ($self, $name) = @_; return if $self->has_created($name); $self->register_created($name => 1 ); if ($self->node->instance->initial_load) { $logger->debug("registering $name during init"); $self->_register_element($name); } else { # try to keep canonical order my $i = 1; my %has = map{ ($_ , $i++ ) } $self->get_element_names_as_created; my $found_me = 0; my $previous_idx = 0 ; my $previous_name ; # traverse the canonical list in reverse order (which includes # accepted elements) ... foreach my $std (reverse @{ $self->node->{model}{element_list} }) { # ... until the new element is found in the canonical list ... if ($name eq $std) { $found_me++; } # ... and the first previous element from the canonical # list already existing in the existing list is found elsif ($found_me and $has{$std}) { $previous_idx = $has{$std}; $previous_name = $std; last; } } # then insert this element in the existing list after the # previous element (which may be 0, if the previous element # was not found, i.e. do an unshift). push it if search has failed. if ($found_me) { if ($logger->is_debug) { my $str = $previous_name ? "after $previous_name" : "at beginning"; $logger->debug("registering $name $str"); } $self->_insert_element($previous_idx, $name); } else { $logger->debug("registering $name at end of list"); $self->_register_element($name); } } } sub get_ordered_element_names { my $self = shift; if ($self->node->instance->canonical) { return $self->get_element_names; } else { # triggers a registration of all remaining elements in _creation_order for ( $self->get_element_names ) { $self->register_element($_); } return $self->get_element_names_as_created; } } 1; __END__ =pod =encoding UTF-8 =head1 NAME Config::Model::BackendTrackOrder - Track read order of elements from configuration =head1 VERSION version 2.149 =head1 SYNOPSIS # inside a backend use Config::Model::BackendTrackOrder; has tracker => ( is => 'ro', isa => 'Config::Model::BackendTrackOrder', lazy_build => 1, ); sub _build_tracker { my $self = shift; return Config::Model::BackendTrackOrder->new( backend_obj => $self, node => $self->node, ) ; } # register elements to record user order $self->tracker->register_element('foo'); $self->tracker->register_element('bar'); # later, when writing data back foreach my $elt ( $self->tracker->get_ordered_element_names ) { # write data } =head1 DESCRIPTION This module is used by backends to record the order of the configuration elements found in user file. Later these elements can be written back in the file using the same order. Data are written in canonical order if C method of the L returns true. =head1 CONSTRUCTOR THe constructor accepts the following parameters: =over 4 =item backend_obj The backend object holding this tracker (required). =item node The node holding the backend above =back =head1 METHODS =head2 register_element Register the element and keep track of the registration order during L Element registered after initial load (i.e . user modification) are registered using canonical order. =head2 get_ordered_element_names Returns a list of elements respecting user's order. Returns the canonical list if Instance canonical attribute is 1. =head1 AUTHOR Dominique Dumont =head1 COPYRIGHT AND LICENSE This software is Copyright (c) 2005-2022 by Dominique Dumont. This is free software, licensed under: The GNU Lesser General Public License, Version 2.1, February 1999 =cut Config-Model-2.149/lib/Config/Model.pm0000644000175000017500000026365214170053137016026 0ustar domidomi# # This file is part of Config-Model # # This software is Copyright (c) 2005-2022 by Dominique Dumont. # # This is free software, licensed under: # # The GNU Lesser General Public License, Version 2.1, February 1999 # package Config::Model 2.149; use 5.20.0; use strict ; use warnings; use Mouse; use Mouse::Util::TypeConstraints; use MouseX::StrictConstructor; use Carp; use Storable ('dclone'); use Data::Dumper (); use Log::Log4perl 1.11 qw(get_logger :levels); use Config::Model::Instance; use Hash::Merge 0.12 qw/merge/; use Path::Tiny 0.053; use File::HomeDir; use Cwd; use Config::Model::Lister; with "Config::Model::Role::Constants"; use parent qw/Exporter/; our @EXPORT_OK = qw/cme initialize_log4perl/; use feature qw/signatures postderef/; no warnings qw/experimental::signatures experimental::postderef/; # used in some tests where we don't want to load # ~/.log4config-model config my $force_default_log; sub force_usage_of_default_log_config () { return $force_default_log = 1; } my $legacy_logger = get_logger("Model::Legacy") ; my $loader_logger = get_logger("Model::Loader") ; my $logger = get_logger("Model") ; # used to keep one Config::Model object to simplify programs based on # cme function my $model_storage; enum LegacyTreament => qw/die warn ignore/; has skip_include => ( isa => 'Bool', is => 'ro', default => 0 ); has model_dir => ( isa => 'Str', is => 'ro', default => 'Config/Model/models' ); has legacy => ( isa => 'LegacyTreament', is => 'ro', default => 'warn' ); has instances => ( isa => 'HashRef[Config::Model::Instance]', is => 'ro', default => sub { {} }, traits => ['Hash'], handles => { store_instance => 'set', get_instance => 'get', has_instance => 'defined', }, ); # Config::Model stores 3 versions of each model # raw_model is the model exactly as passed by the user. Since the format is quite # liberal (e.g legacy parameters, grouped declaration of elements like '[qw/foo bar/] => {}}', # element description in class or in element declaration)), this raw format is not # usable without normalization (done by normalize_class_parameters) # the key if this hash is a model name has raw_models => ( isa => 'HashRef', is => 'ro', default => sub { {} }, traits => ['Hash'], handles => { raw_model_exists => 'exists', raw_model_defined => 'defined', raw_model => 'get', get_raw_model => 'get', store_raw_model => 'set', raw_model_names => 'keys', }, ); # the result of normalization is stored here. Normalized model aggregate user models and # augmented features (the one found in Foo.d directory). inclusion of other class is NOT # yet done. normalized_models are created while loading files (load method) or creating # configuration classes (create_config_class) has normalized_models => ( isa => 'HashRef', is => 'ro', default => sub { {} }, traits => ['Hash'], handles => { normalized_model_exists => 'exists', normalized_model_defined => 'defined', normalized_model => 'get', store_normalized_model => 'set', normalized_model_names => 'keys', }, ); # This attribute contain the model that will be used by Config::Model::Node. They # are created on demand when get_model is called. When created the inclusion of # other classes is done according to the class 'include' parameter. Note that get_model # will try to call load if the required normalized_model is not known (lazy loading) has models => ( isa => 'HashRef', is => 'ro', default => sub { {} }, traits => ['Hash'], handles => { model_exists => 'exists', model_defined => 'defined', _get_model => 'get', _store_model => 'set', }, ); # model snippet may be loaded when the target class is not available # so they must be stored before being used. has model_snippets => ( isa => 'ArrayRef', is => 'ro', default => sub { [] }, traits => ['Array'], handles => { add_snippet => 'push', all_snippets => 'elements', }, ); enum 'LOG_LEVELS', [ qw/ERROR WARN INFO DEBUG TRACE/ ]; has log_level => ( isa => 'LOG_LEVELS', is => 'ro', ); has skip_inheritance => ( isa => 'Bool', is => 'ro', default => 0, trigger => sub { my $self = shift; $self->show_legacy_issue("skip_inheritance is deprecated, use skip_include"); $self->skip_include = $self->skip_inheritance; } ); # remove this hack mid 2022 around BUILDARGS => sub ($orig, $class, %args) { my %new; foreach my $k (keys %args) { if (defined $args{$k}) { $new{$k} = $args{$k}; } else { # cannot use logger, it's not initialised yet croak("Config::Model new: passing undefined constructor argument is deprecated ($k argument)\n"); } } return $class->$orig(%new); }; # keep this as a separate sub from BUILD. So user can call it before # creating Config::Model object sub initialize_log4perl (@args) { if (ref $args[0]) { # may be called as $self-> initialize_log4perl shift @args; } my %args = @args; my $log4perl_syst_conf_file = path('/etc/log4config-model.conf'); # avoid undef warning when homedir is not defined (e.g. with Debian cowbuilder) my $home = File::HomeDir->my_home // ''; my $log4perl_user_conf_file = path( $home . '/.log4config-model' ); my $fallback_conf_file = path($INC{"Config/Model.pm"}) ->parent->child("Model/log4perl.conf") ; my $log4perl_file = $force_default_log ? $fallback_conf_file # for tests : $log4perl_user_conf_file->is_file ? $log4perl_user_conf_file : $log4perl_syst_conf_file->is_file ? $log4perl_syst_conf_file : $fallback_conf_file; my %log4perl_conf = map { split /\s*=\s*/,$_,2; } grep { chomp; ! /^\s*#/ } $log4perl_file->lines; my $verbose = $args{verbose}; if (defined $verbose) { my @loggers = ref $verbose ? @$verbose : $verbose; foreach my $logger (@loggers) { $log4perl_conf{"log4perl.logger.Verbose.$logger"} = "INFO, PlainMsgOnScreen"; } } Log::Log4perl::init(\%log4perl_conf); return \%log4perl_conf; # for tests } sub BUILD { my $self = shift; my $args = shift; initialize_log4perl(verbose => $args->{verbose}) unless Log::Log4perl->initialized(); return; } sub show_legacy_issue { my $self = shift; my $ref = shift; my $behavior = shift || $self->legacy; my @msg = ref $ref ? @$ref : $ref; unshift @msg, "Model "; if ( $behavior eq 'die' ) { die @msg, "\n"; } elsif ( $behavior eq 'warn' ) { $legacy_logger->warn(@msg); } elsif ( $behavior eq 'note' ) { $legacy_logger->info( @msg); } return; } sub _tweak_instance_args { my ($args) = @_ ; my $application = $args->{application} ; my $cat = ''; if (defined $application) { my ( $categories, $appli_info, $appli_map ) = Config::Model::Lister::available_models; # root_class_name may override class found (or not) by appli in tests if (not $args->{root_class_name}) { $args->{root_class_name} = $appli_map->{$application} || die "Unknown application $application. Expected one of " . join(' ',sort keys %$appli_map)."\n"; } $cat = $appli_info->{_category} // ''; # may be empty in tests # config_dir may be specified in application file $args->{config_dir} //= $appli_info->{$application}{config_dir}; $args->{appli_info} = $appli_info->{$application} // {}; } my $app_name = $application; if ($cat eq 'application') { # store dir in name to distinguish different runs of the same # app in different directories. $application .= " in " . cwd; } $args->{name} = delete $args->{instance_name} # backward compat with test || delete $args->{name} # preferred parameter || $app_name # fallback in most cases || 'default'; # fallback mostly in tests return; } sub cme (@args) { my %args = @args == 1 ? ( application => $args[0]) : @args ; if (my $force = delete $args{'force-load'}) { $args{check} = 'no' if $force; } my $cat =_tweak_instance_args(\%args); my $m_args = delete $args{model_args} // {} ; # used for tests # model_storage is used to keep Config::Model object alive $model_storage //= Config::Model->new(%$m_args); return $model_storage->instance(%args); } sub instance ($self, @args) { my %args = @args == 1 ? ( application => $args[0]) : @args ; # also creates a default name _tweak_instance_args(\%args); if ( $args{name} and $self->has_instance($args{name}) ) { return $self->get_instance($args{name}); } croak "Model: can't create instance without application or root_class_name " unless $args{root_class_name}; if ( defined $args{model_file} ) { my $file = delete $args{model_file}; $self->load( $args{root_class_name}, $file ); } my $i = Config::Model::Instance->new( config_model => $self, %args # for optional parameters like *directory ); $self->store_instance($args{name}, $i); return $i; } sub instance_names { my $self = shift; my @all = sort keys %{ $self->instances }; return @all; } # unpacked model is: # { # element_list => [ ... ], # element => { element_name => element_data (left as is) }, # class_description => , # include => 'class_name', # include_after => 'element_name', # } # description, summary, level, status are moved # into element description. my @legal_params_to_move = ( qw/read_config write_config rw_config/, # read/write stuff # this parameter is filled by class generated by a program. It may # be used to avoid interactive edition of a generated model 'generated_by', qw/class_description author copyright gist license include include_after include_backend class/ ); my @other_legal_params = qw/ author element status description summary level accept/; # keep as external API. All internal call go through _store_model # See comments around raw_models attribute for explanations sub create_config_class ($self, %raw_model) { my $config_class_name = delete $raw_model{name} or croak "create_config_class: no config class name"; get_logger("Model")->info("Creating class $config_class_name"); if ( $self->model_exists($config_class_name) ) { Config::Model::Exception::ModelDeclaration->throw( error => "create_config_class: attempt to clobber $config_class_name" . " config class name " ); } $self->store_raw_model( $config_class_name, dclone( \%raw_model ) ); my $model = $self->normalize_class_parameters( $config_class_name, \%raw_model ); $self->store_normalized_model( $config_class_name, $model ); return $config_class_name; } sub merge_included_class { my ( $self, $config_class_name ) = @_; my $normalized_model = $self->normalized_model($config_class_name); my $model = dclone $normalized_model ; # add included elements if ( $self->skip_include and defined $normalized_model->{include} ) { my $inc = $normalized_model->{include}; $model->{include} = ref $inc ? $inc : [$inc]; $model->{include_after} = $normalized_model->{include_after} if defined $normalized_model->{include_after}; } else { # include class in raw_copy, normalized_model is left as is $self->include_class( $config_class_name, $model ); } # add included backend if ( $self->skip_include and defined $normalized_model->{include_backend} ) { my $inc = $normalized_model->{include_backend}; $model->{include_backend} = ref $inc ? $inc : [$inc]; } else { # include read/write config specifications in raw_copy, # normalized_model is left as is $self->include_backend( $config_class_name, $model ); } return $model; } sub include_backend { my $self = shift; my $class_name = shift || croak "include_backend: undef includer"; my $target_model = shift || die "include_backend:: undefined target_model"; my $included_classes = delete $target_model->{include_backend}; return () unless defined $included_classes; foreach my $included_class (@$included_classes) { # takes care of recursive include, because get_model will perform # includes (and normalization). Is already a dclone my $included_model = $self->get_model_clone($included_class); foreach my $rw (qw/rw_config read_config write_config config_dir/) { if ($target_model->{$rw} and $included_model->{$rw}) { my $msg = "Included $rw from $included_class cannot clobber " . "existing data in $class_name"; Config::Model::Exception::ModelDeclaration->throw( error => $msg ); } elsif ($included_model->{$rw}) { $target_model->{$rw} = $included_model->{$rw}; } } } return; } sub normalize_class_parameters { my $self = shift; my $config_class_name = shift || die; my $normalized_model = shift || die; my $model = {}; # sanity check my $raw_name = delete $normalized_model->{name}; if ( defined $raw_name and $config_class_name ne $raw_name ) { my $e = "internal: config_class_name $config_class_name ne model name $raw_name"; Config::Model::Exception::ModelDeclaration->throw( error => $e ); } my @element_list; # first construct the element list my @compact_list = @{ $normalized_model->{element} || [] }; while (@compact_list) { my ( $item, $info ) = splice @compact_list, 0, 2; # store the order of element as declared in 'element' push @element_list, ref($item) ? @$item : ($item); } if ( defined $normalized_model->{inherit_after} ) { $self->show_legacy_issue([ "Model $config_class_name: inherit_after is deprecated ", "in favor of include_after" ]); $normalized_model->{include_after} = delete $normalized_model->{inherit_after}; } if ( defined $normalized_model->{inherit} ) { $self->show_legacy_issue( "Model $config_class_name: inherit is deprecated in favor of include"); $normalized_model->{include} = delete $normalized_model->{inherit}; } foreach my $info (@legal_params_to_move) { next unless defined $normalized_model->{$info}; $model->{$info} = delete $normalized_model->{$info}; } # first deal with perl file and cds_file backend $self->translate_legacy_backend_info( $config_class_name, $model ); # handle accept parameter my @accept_list; my %accept_hash; my $accept_info = delete $normalized_model->{'accept'} || []; while (@$accept_info) { my $name_match = shift @$accept_info; # should be a regexp # handle legacy if ( ref $name_match ) { my $implicit = defined $name_match->{name_match} ? '' : 'implicit '; unshift @$accept_info, $name_match; # put data back in list $name_match = delete $name_match->{name_match} || '.*'; $logger->warn("class $config_class_name: name_match ($implicit$name_match)", " in accept is deprecated"); } push @accept_list, $name_match; $accept_hash{$name_match} = shift @$accept_info; } $model->{accept} = \%accept_hash; $model->{accept_list} = \@accept_list; # check for duplicate in @element_list. my %check_list; foreach (@element_list) { $check_list{$_}++ }; my @extra = grep { $check_list{$_} > 1 } keys %check_list; if (@extra) { Config::Model::Exception::ModelDeclaration->throw( error => "class $config_class_name: @extra element " . "is declared more than once. Check the included parts" ); } $self->handle_experience_permission( $config_class_name, $normalized_model ); # element is handled first foreach my $info_name (qw/element status description summary level/) { my $raw_compact_info = delete $normalized_model->{$info_name}; next unless defined $raw_compact_info; Config::Model::Exception::ModelDeclaration->throw( error => "Data for parameter $info_name of $config_class_name" . " is not an array ref" ) unless ref($raw_compact_info) eq 'ARRAY'; my @raw_info = @$raw_compact_info; while (@raw_info) { my ( $item, $info ) = splice @raw_info, 0, 2; my @element_names = ref($item) ? @$item : ($item); # move element informations (handled first) if ( $info_name eq 'element' ) { # warp can be found only in element item $self->translate_legacy_info( $config_class_name, $element_names[0], $info ); $self->handle_experience_permission( $config_class_name, $info ); # copy in element data *after* legacy translation foreach (@element_names) { $model->{element}{$_} = dclone($info); }; } # move some information into element declaration (without clobberring) elsif ( $info_name =~ /description|level|summary|status/ ) { foreach (@element_names) { Config::Model::Exception::ModelDeclaration->throw( error => "create class $config_class_name: '$info_name' " . "declaration for non declared element '$_'" ) unless defined $model->{element}{$_}; $model->{element}{$_}{$info_name} ||= $info; } } else { die "Unexpected element $item in $config_class_name model"; } } } Config::Model::Exception::ModelDeclaration->throw( error => "create class $config_class_name: unexpected " . "parameters '" . join( ', ', sort keys %$normalized_model ) . "' " . "Expected '" . join( "', '", @legal_params_to_move, @other_legal_params ) . "'" ) if keys %$normalized_model; $model->{element_list} = \@element_list; return $model; } sub handle_experience_permission { my ( $self, $config_class_name, $model ) = @_; if (delete $model->{permission}) { die "$config_class_name: parameter permission is obsolete\n"; } if (delete $model->{experience}) { carp "experience parameter is deprecated"; } return; } sub translate_legacy_info { my $self = shift; my $config_class_name = shift || die; my $elt_name = shift; my $info = shift; $self->translate_warped_node_info( $config_class_name, $elt_name, 'warped_node', $info ); #translate legacy warp information if ( defined $info->{warp} ) { $self->translate_warp_info( $config_class_name, $elt_name, $info->{type}, $info->{warp} ); } $self->translate_cargo_info( $config_class_name, $elt_name, $info ); if ( defined $info->{cargo} && defined $info->{cargo}{type} && $info->{cargo}{type} eq 'warped_node' ) { $self->translate_warped_node_info( $config_class_name, $elt_name, 'warped_node', $info->{cargo} ); } if ( defined $info->{cargo} and defined $info->{cargo}{warp} ) { $self->translate_warp_info( $config_class_name, $elt_name, $info->{cargo}{type}, $info->{cargo}{warp} ); } # compute cannot be warped if ( defined $info->{compute} ) { $self->translate_compute_info( $config_class_name, $elt_name, $info, 'compute' ); $self->translate_allow_compute_override( $config_class_name, $elt_name, $info ); } if ( defined $info->{cargo} and defined $info->{cargo}{compute} ) { $self->translate_compute_info( $config_class_name, $elt_name, $info->{cargo}, 'compute' ); $self->translate_allow_compute_override( $config_class_name, $elt_name, $info->{cargo} ); } # refer_to cannot be warped if ( defined $info->{refer_to} ) { $self->translate_compute_info( $config_class_name, $elt_name, $info, refer_to => 'computed_refer_to' ); } if ( defined $info->{cargo} and defined $info->{cargo}{refer_to} ) { $self->translate_compute_info( $config_class_name, $elt_name, $info->{cargo}, refer_to => 'computed_refer_to' ); } # translate id default param # default cannot be stored in cargo since is applies to the id itself if ( defined $info->{type} and ( $info->{type} eq 'list' or $info->{type} eq 'hash' ) ) { if ( defined $info->{default} ) { $self->translate_id_default_info( $config_class_name, $elt_name, $info ); } if ( defined $info->{auto_create} ) { $self->translate_id_auto_create( $config_class_name, $elt_name, $info ); } $self->translate_id_min_max( $config_class_name, $elt_name, $info ); $self->translate_id_names( $config_class_name, $elt_name, $info ); if ( defined $info->{warp} ) { my $rules_a = $info->{warp}{rules}; my %h = @$rules_a; foreach my $rule_effect ( values %h ) { $self->translate_id_names( $config_class_name, $elt_name, $rule_effect ); $self->translate_id_min_max( $config_class_name, $elt_name, $rule_effect ); next unless defined $rule_effect->{default}; $self->translate_id_default_info( $config_class_name, $elt_name, $rule_effect ); } } $self->translate_id_class($config_class_name, $elt_name, $info ); } if ( defined $info->{type} and ( $info->{type} eq 'leaf' ) ) { $self->translate_legacy_builtin( $config_class_name, $info, $info, ); } if ( defined $info->{type} and ( $info->{type} eq 'check_list' ) ) { $self->translate_legacy_built_in_list( $config_class_name, $info, $info, ); } $legacy_logger->debug( Data::Dumper->Dump( [$info], [ 'translated_' . $elt_name ] ) ) if $legacy_logger->is_debug; return; } sub translate_legacy_backend_info { my ( $self, $config_class_name, $model ) = @_; # trap multi backend and change array spec into single spec foreach my $config (qw/read_config write_config/) { my $ref = $model->{$config}; if ($ref and ref($ref) eq 'ARRAY') { if (@$ref == 1) { $model->{$config} = $ref->[0]; } elsif (@$ref > 1){ $self->show_legacy_issue("$config_class_name $config: multiple backends are obsolete. You now must use only one backend.", 'die'); } } } # move read_config spec in re_config if ($model->{read_config}) { $self->show_legacy_issue("$config_class_name: read_config specification is deprecated, please move in rw_config", 'warn'); $model->{rw_config} = delete $model->{read_config}; } # merge write_config spec in rw_config if ($model->{write_config}) { $self->show_legacy_issue("$config_class_name: write_config specification is deprecated, please merge with read_config and move in rw_config", 'warn'); foreach (keys %{$model->{write_config}}) { $model->{rw_config}{$_} = $model->{write_config}{$_} } delete $model->{write_config}; } my $ref = $model->{'rw_config'} || return; die "undefined backend in rw_config spec of class $config_class_name\n" unless $ref->{backend} ; if ($ref->{backend} eq 'custom') { my $msg = "$config_class_name: custom read/write backend is obsolete." ." Please replace with a backend inheriting Config::Model::Backend::Any"; $self->show_legacy_issue( $msg, 'die'); } if ( $ref->{backend} =~ /^(perl|ini|cds)$/ ) { my $backend = $ref->{backend}; $self->show_legacy_issue("$config_class_name: deprecated backend '$backend'. Should be '$ {backend}_file'", 'warn'); $ref->{backend} .= "_file"; } if ( defined $ref->{allow_empty} ) { $self->show_legacy_issue("$config_class_name: backend $ref->{backend}: allow_empty is deprecated. Use auto_create", 'warn'); $ref->{auto_create} = delete $ref->{allow_empty}; } return; } sub translate_cargo_info { my $self = shift; my $config_class_name = shift; my $elt_name = shift; my $info = shift; my $c_type = delete $info->{cargo_type}; return unless defined $c_type; $self->show_legacy_issue("$config_class_name->$elt_name: parameter cargo_type is deprecated."); my %cargo; if ( defined $info->{cargo_args} ) { %cargo = %{ delete $info->{cargo_args} }; $self->show_legacy_issue( "$config_class_name->$elt_name: parameter cargo_args is deprecated."); } $cargo{type} = $c_type; if ( defined $info->{config_class_name} ) { $cargo{config_class_name} = delete $info->{config_class_name}; $self->show_legacy_issue([ "$config_class_name->$elt_name: parameter config_class_name is ", "deprecated. This one must be specified within cargo. ", "Ie. cargo=>{config_class_name => 'FooBar'}" ]); } $info->{cargo} = \%cargo; $legacy_logger->debug( Data::Dumper->Dump( [$info], [ 'translated_' . $elt_name ] ) ) if $legacy_logger->is_debug; return; } sub translate_id_names { my $self = shift; my $config_class_name = shift; my $elt_name = shift; my $info = shift; $self->translate_name( $config_class_name, $elt_name, $info, 'allow', 'allow_keys', 'die' ); $self->translate_name( $config_class_name, $elt_name, $info, 'allow_from', 'allow_keys_from', 'die' ); $self->translate_name( $config_class_name, $elt_name, $info, 'follow', 'follow_keys_from', 'die' ); return; } sub translate_name { my ($self, $config_class_name, $elt_name, $info, $from, $to, $legacy) = @_; if ( defined $info->{$from} ) { $self->show_legacy_issue( "$config_class_name->$elt_name: parameter $from is deprecated in favor of $to", $legacy ); $info->{$to} = delete $info->{$from}; } return; } sub translate_allow_compute_override { my $self = shift; my $config_class_name = shift; my $elt_name = shift; my $info = shift; if ( defined $info->{allow_compute_override} ) { $self->show_legacy_issue( "$config_class_name->$elt_name: parameter allow_compute_override is deprecated in favor of compute -> allow_override" ); $info->{compute}{allow_override} = delete $info->{allow_compute_override}; } return; } sub translate_compute_info { my $self = shift; my $config_class_name = shift; my $elt_name = shift; my $info = shift; my $old_name = shift; my $new_name = shift || $old_name; if ( ref( $info->{$old_name} ) eq 'ARRAY' ) { my $compute_info = delete $info->{$old_name}; $legacy_logger->debug( "translate_compute_info $elt_name input:\n", Data::Dumper->Dump( [$compute_info], [qw/compute_info/] ) ) if $legacy_logger->is_debug; $self->show_legacy_issue([ "$config_class_name->$elt_name: specifying compute info with ", "an array ref is deprecated" ]); my ( $user_formula, %var ) = @$compute_info; my $replace_h; foreach ( keys %var ) { $replace_h = delete $var{$_} if ref( $var{$_} ) }; # cleanup user formula $user_formula =~ s/\$(\w+)\{/\$replace{/g; # cleanup variable foreach ( values %var ) { s/\$(\w+)\{/\$replace{/g }; # change the hash *in* the info structure $info->{$new_name} = { formula => $user_formula, variables => \%var, }; $info->{$new_name}{replace} = $replace_h if defined $replace_h; $legacy_logger->debug( "translate_warp_info $elt_name output:\n", Data::Dumper->Dump( [ $info->{$new_name} ], [ 'new_' . $new_name ] ) ) if $legacy_logger->is_debug; } return; } sub translate_id_class { my $self = shift; my $config_class_name = shift || die; my $elt_name = shift; my $info = shift; $legacy_logger->debug( "translate_id_class $elt_name input:\n", Data::Dumper->Dump( [$info], [qw/info/] ) ) if $legacy_logger->is_debug; my $class_overide_param = $info->{type}.'_class'; my $class_overide = $info->{$class_overide_param}; if ($class_overide) { $info->{class} = $class_overide; $self->show_legacy_issue([ "$config_class_name->$elt_name: '$class_overide_param' is deprecated, ", "Use 'class' instead." ]); } $legacy_logger->debug( "translate_id_class $elt_name output:", Data::Dumper->Dump( [$info], [qw/new_info/]) ) if $legacy_logger->is_debug; return; } # internal: translate default information for id element sub translate_id_default_info { my $self = shift; my $config_class_name = shift || die; my $elt_name = shift; my $info = shift; $legacy_logger->debug( "translate_id_default_info $elt_name input:\n", Data::Dumper->Dump( [$info], [qw/info/] ) ) if $legacy_logger->is_debug; my $warn = "$config_class_name->$elt_name: 'default' parameter for list or " . "hash element is deprecated. "; my $def_info = delete $info->{default}; if ( ref($def_info) eq 'HASH' ) { $info->{default_with_init} = $def_info; $self->show_legacy_issue([ $warn, "Use default_with_init" ]); } elsif ( ref($def_info) eq 'ARRAY' ) { $info->{default_keys} = $def_info; $self->show_legacy_issue([ $warn, "Use default_keys" ]); } else { $info->{default_keys} = [$def_info]; $self->show_legacy_issue([ $warn, "Use default_keys" ]); } $legacy_logger->debug( "translate_id_default_info $elt_name output:", Data::Dumper->Dump( [$info], [qw/new_info/]) ) if $legacy_logger->is_debug; return; } # internal: translate auto_create information for id element sub translate_id_auto_create { my $self = shift; my $config_class_name = shift || die; my $elt_name = shift; my $info = shift; $legacy_logger->debug( "translate_id_auto_create $elt_name input:", Data::Dumper->Dump( [$info], [qw/info/] ) ) if $legacy_logger->is_debug; my $warn = "$config_class_name->$elt_name: 'auto_create' parameter for list or " . "hash element is deprecated. "; my $ac_info = delete $info->{auto_create}; if ( $info->{type} eq 'hash' ) { $info->{auto_create_keys} = ref($ac_info) eq 'ARRAY' ? $ac_info : [$ac_info]; $self->show_legacy_issue([ $warn, "Use auto_create_keys" ]); } elsif ( $info->{type} eq 'list' ) { $info->{auto_create_ids} = $ac_info; $self->show_legacy_issue([ $warn, "Use auto_create_ids" ]); } else { die "Unexpected element ($elt_name) type $info->{type} ", "for translate_id_auto_create"; } $legacy_logger->debug( "translate_id_default_info $elt_name output:\n", Data::Dumper->Dump( [$info], [qw/new_info/] ) ) if $legacy_logger->is_debug; return; } sub translate_id_min_max { my $self = shift; my $config_class_name = shift || die; my $elt_name = shift; my $info = shift; foreach my $bad (qw/min max/) { next unless defined $info->{$bad}; $legacy_logger->debug( "translate_id_min_max $elt_name $bad:") if $legacy_logger->is_debug; my $good = $bad . '_index'; my $warn = "$config_class_name->$elt_name: '$bad' parameter for list or " . "hash element is deprecated. Use '$good'"; $info->{$good} = delete $info->{$bad}; } return; } sub translate_warped_node_info { my ( $self, $config_class_name, $elt_name, $type, $info ) = @_; $legacy_logger->debug( "translate_warped_node_info $elt_name input:\n", Data::Dumper->Dump( [$info], [qw/info/] ) ) if $legacy_logger->is_debug; # type may not be defined when translating class snippet used to augment a class my $elt_type = $info->{type} ; foreach my $parm (qw/follow rules/) { next unless $info->{$parm}; next if defined $elt_type and $elt_type ne 'warped_node'; $self->show_legacy_issue( "$config_class_name->$elt_name: using $parm parameter in " ."warped node is deprecated. $parm must be specified in a warp parameter." ); $info->{warp}{$parm} = delete $info->{$parm}; } $legacy_logger->debug( "translate_warped_node_info $elt_name output:\n", Data::Dumper->Dump( [$info], [qw/new_info/] ) ) if $legacy_logger->is_debug; return; } # internal: translate warp information into 'boolean expr' => { ... } sub translate_warp_info { my ( $self, $config_class_name, $elt_name, $type, $warp_info ) = @_; $legacy_logger->debug( "translate_warp_info $elt_name input:\n", Data::Dumper->Dump( [$warp_info], [qw/warp_info/] ) ) if $legacy_logger->is_debug; my $follow = $self->translate_follow_arg( $config_class_name, $elt_name, $warp_info->{follow} ); # now, follow is only { w1 => 'warp1', w2 => 'warp2'} my @warper_items = values %$follow; my $multi_follow = @warper_items > 1 ? 1 : 0; my $rules = $self->translate_rules_arg( $config_class_name, $elt_name, $type, \@warper_items, $warp_info->{rules} ); $warp_info->{follow} = $follow; $warp_info->{rules} = $rules; $legacy_logger->debug( "translate_warp_info $elt_name output:\n", Data::Dumper->Dump( [$warp_info], [qw/new_warp_info/] ) ) if $legacy_logger->is_debug; return; } # internal sub translate_multi_follow_legacy_rules { my ( $self, $config_class_name, $elt_name, $warper_items, $raw_rules ) = @_; my @rules; # we have more than one warper_items for ( my $r_idx = 0 ; $r_idx < $#$raw_rules ; $r_idx += 2 ) { my $key_set = $raw_rules->[$r_idx]; my @keys = ref($key_set) ? @$key_set : ($key_set); # legacy: check the number of keys in the @rules set if ( @keys != @$warper_items and $key_set !~ /\$\w+/ ) { Config::Model::Exception::ModelDeclaration->throw( error => "Warp rule error in " . "'$config_class_name->$elt_name'" . ": Wrong nb of keys in set '@keys'," . " Expected " . scalar @$warper_items . " keys" ); } # legacy: # if a key of a rule (e.g. f1 or b1) is an array ref, all the # values passed in the array are considered as valid. # i.e. [ [ f1a, f1b] , b1 ] => { ... } # is equivalent to # [ f1a, b1 ] => { ... }, [ f1b , b1 ] => { ... } # now translate [ [ f1a, f1b] , b1 ] => { ... } # into "( $f1 eq f1a or $f1 eq f1b ) and $f2 eq b1)" => { ... } my @bool_expr; my $b_idx = 0; foreach my $key (@keys) { if ( ref $key ) { my @expr = map { "\$f$b_idx eq '$_'" } @$key; push @bool_expr, "(" . join( " or ", @expr ) . ")"; } elsif ( $key !~ /\$\w+/ ) { push @bool_expr, "\$f$b_idx eq '$key'"; } else { push @bool_expr, $key; } $b_idx++; } push @rules, join( ' and ', @bool_expr ), $raw_rules->[ $r_idx + 1 ]; } return @rules; } sub translate_follow_arg { my $self = shift; my $config_class_name = shift; my $elt_name = shift; my $raw_follow = shift; if ( ref($raw_follow) eq 'HASH' ) { # follow is { w1 => 'warp1', w2 => 'warp2'} return $raw_follow; } elsif ( ref($raw_follow) eq 'ARRAY' ) { # translate legacy follow arguments ['warp1','warp2',...] my $follow = {}; my $idx = 0; foreach ( @$raw_follow ) { $follow->{ 'f' . $idx++ } = $_ } ; return $follow; } elsif ( defined $raw_follow ) { # follow is a plain string return { f1 => $raw_follow }; } else { return {}; } } sub translate_rules_arg { my ( $self, $config_class_name, $elt_name, $type, $warper_items, $raw_rules ) = @_; my $multi_follow = @$warper_items > 1 ? 1 : 0; my $follow = @$warper_items; # $rules is either: # { f1 => { ... } } ( may be [ f1 => { ... } ] ?? ) # [ 'boolean expr' => { ... } ] # legacy: # [ f1, b1 ] => {..} ,[ f1,b2 ] => {...}, [f2,b1] => {...} ... # foo => {...} , bar => {...} my @rules; if ( ref($raw_rules) eq 'HASH' ) { # transform the hash { foo => { ...} } # into array ref [ '$f1 eq foo' => { ... } ] my $h = $raw_rules; @rules = $follow ? map { ( "\$f1 eq '$_'", $h->{$_} ) } keys %$h : keys %$h; } elsif ( ref($raw_rules) eq 'ARRAY' ) { if ($multi_follow) { push @rules, $self->translate_multi_follow_legacy_rules( $config_class_name, $elt_name, $warper_items, $raw_rules ); } else { # now translate [ f1a, f1b] => { ... } # into "$f1 eq f1a or $f1 eq f1b " => { ... } my @raw_rules = @{$raw_rules}; for ( my $r_idx = 0 ; $r_idx < $#raw_rules ; $r_idx += 2 ) { my $key_set = $raw_rules[$r_idx]; my @keys = ref($key_set) ? @$key_set : ($key_set); my @bool_expr = $follow ? map { /\$/ ? $_ : "\$f1 eq '$_'" } @keys : @keys; push @rules, join( ' or ', @bool_expr ), $raw_rules[ $r_idx + 1 ]; } } } elsif ( defined $raw_rules ) { Config::Model::Exception::ModelDeclaration->throw( error => "Warp rule error in element " . "'$config_class_name->$elt_name': " . "rules must be a hash ref. Got '$raw_rules'" ); } for ( my $idx = 1 ; $idx < @rules ; $idx += 2 ) { next unless ( ref $rules[$idx] eq 'HASH' ); # other cases are illegal and trapped later $self->handle_experience_permission( $config_class_name, $rules[$idx] ); next unless defined $type and $type eq 'leaf'; $self->translate_legacy_builtin( $config_class_name, $rules[$idx], $rules[$idx] ); } return \@rules; } sub translate_legacy_builtin { my ( $self, $config_class_name, $model, $normalized_model ) = @_; my $raw_builtin_default = delete $normalized_model->{built_in}; return unless defined $raw_builtin_default; $legacy_logger->debug( Data::Dumper->Dump( [$normalized_model], ['builtin to translate'] ) ) if $legacy_logger->is_debug; $self->show_legacy_issue([ "$config_class_name: parameter 'built_in' is deprecated " . "in favor of 'upstream_default'" ]); $model->{upstream_default} = $raw_builtin_default; $legacy_logger->debug( Data::Dumper->Dump( [$model], ['translated_builtin'] )) if $legacy_logger->is_debug; return; } sub translate_legacy_built_in_list { my ( $self, $config_class_name, $model, $normalized_model ) = @_; my $raw_builtin_default = delete $normalized_model->{built_in_list}; return unless defined $raw_builtin_default; $legacy_logger->debug( Data::Dumper->Dump( [$normalized_model], ['built_in_list to translate'] ) ) if $legacy_logger->is_debug; $self->show_legacy_issue([ "$config_class_name: parameter 'built_in_list' is deprecated " . "in favor of 'upstream_default_list'" ]); $model->{upstream_default_list} = $raw_builtin_default; $legacy_logger->debug( Data::Dumper->Dump( [$model], ['translated_built_in_list'] )) if $legacy_logger->is_debug; return; } sub include_class { my $self = shift; my $class_name = shift || croak "include_class: undef includer"; my $target_model = shift || die "include_class: undefined target_model"; my $include_class = delete $target_model->{include}; return () unless defined $include_class; my $include_after = delete $target_model->{include_after}; my @includes = ref $include_class ? @$include_class : ($include_class); # use reverse because included classes are *inserted* in front # of the list (or inserted after $include_after foreach my $inc ( reverse @includes ) { $self->include_one_class( $class_name, $target_model, $inc, $include_after ); } return; } sub include_one_class { my $self = shift; my $class_name = shift || croak "include_class: undef includer"; my $target_model = shift || croak "include_class: undefined target_model"; my $include_class = shift || croak "include_class: undef include_class param"; my $include_after = shift; get_logger('Model')->debug("class $class_name includes $include_class"); if ( defined $include_class and defined $self->{included_class}{$class_name}{$include_class} ) { Config::Model::Exception::ModelDeclaration->throw( error => "Recursion error ? $include_class has " . "already been included by $class_name." ); } $self->{included_class}{$class_name}{$include_class} = 1; # takes care of recursive include, because get_model will perform # includes (and normalization). Is already a dclone my $included_model = $self->get_model_clone($include_class); # now include element in element_list (special treatment because order is # important) my $target_list = $target_model->{element_list}; my $included_list = $included_model->{element_list}; my $splice_idx = 0; if ( defined $include_after and defined $included_model->{element} ) { my $idx = 0; my %elt_idx = map { ( $_, $idx++ ); } @$target_list; if ( not defined $elt_idx{$include_after} ) { my $msg = "Unknown element for 'include_after': " . "$include_after, expected " . join( ' ', sort keys %elt_idx ); Config::Model::Exception::ModelDeclaration->throw( error => $msg ); } # + 1 because we splice *after* $include_after $splice_idx = $elt_idx{$include_after} + 1; } splice( @$target_list, $splice_idx, 0, @$included_list ); get_logger('Model')->debug("class $class_name new elt list: @$target_list"); # now actually include all elements my $target_element = $target_model->{element} ||= {}; foreach my $included_elt (@$included_list) { if ( not defined $target_element->{$included_elt} ) { get_logger('Model')->debug("class $class_name includes elt $included_elt"); $target_element->{$included_elt} = $included_model->{element}{$included_elt}; } else { Config::Model::Exception::ModelDeclaration->throw( error => "Cannot clobber element '$included_elt' in $class_name" . " (included from $include_class)" ); } } get_logger('Model')->debug("class $class_name include $include_class done"); return; } sub find_model_file_in_dir ($model_name, $model_path) { foreach my $ext (qw/yml yaml pl/) { my $sub_path = $model_name =~ s!::!/!rg; my $path_load_file = $model_path->child($sub_path . '.' . $ext); return $path_load_file if $path_load_file->exists; } return; } sub find_model_file_in_inc { my ($self, $model_name, $load_file) = @_; my $path_load_file ; if ($load_file and $load_file =~ m!^/! ) { # load_file is absolute, do not search in @INC $path_load_file = $load_file; } elsif ($self->model_dir and $self->model_dir =~ m!^/!) { # model_dir is absolute, do not search in @INC my $model_path = path($self->model_dir); $path_load_file = find_model_file_in_dir ($model_name, $model_path); Config::Model::Exception::ModelDeclaration->throw( error => "Cannot find $model_name file in $model_path" ) unless $path_load_file; } else { foreach my $inc_str (@INC) { my $inc_path = path($inc_str); if ($load_file) { $path_load_file = $inc_path->child($load_file); } else { my $sub_path = $model_name =~ s!::!/!rg; my $model_path = $inc_path->child($self->model_dir); foreach my $ext (qw/yml yaml pl/) { $path_load_file = $model_path->child($sub_path . '.' . $ext); last if $path_load_file->exists; } } last if $path_load_file->exists; } } Config::Model::Exception::ModelDeclaration->throw( error => "Cannot find $model_name file in \@INC" ) unless $path_load_file; $loader_logger->debug("model $model_name from file $path_load_file"); return $path_load_file; } sub load_model_plugins { my ($self, @model_names) = @_; # look for additional model information my %model_graft_by_name; my %done; # avoid loading twice the same snippet (where system version may clobber dev version) foreach my $inc_str (@INC) { foreach my $name ( @model_names ) { my $snippet_path = $name; $snippet_path =~ s/::/\//g; my $snippet_dir = path($inc_str)->absolute->child($self->model_dir)->child($snippet_path . '.d'); $loader_logger->trace("looking for snippet in $snippet_dir"); if ( $snippet_dir->is_dir ) { my $iter = $snippet_dir->iterator({ recurse => 1 }); while ( my $snippet_file = $iter->() ) { next unless $snippet_file =~ /\.pl$/; # $snippet_file (Path::Tiny object) was # constructed from @INC content (i.e. $inc_str) # and contains an absolute path. Since # _load_model_in_hash uses 'do' (which may search # in @INC), the file path passed to # _load_model_in_hash must be either absolute or # relative to $inc_str my $snippet_file_rel = $snippet_file->relative($inc_str); my $done_key = $name . ':' . $snippet_file_rel; next if $done{$done_key}; $loader_logger->info("Found snippet $snippet_file in $inc_str dir"); my $snippet_model = $self->_load_model_file($snippet_file); $self->_merge_model_in_hash( \%model_graft_by_name, $snippet_model, $snippet_file_rel); $done{$done_key} = 1; } } } } return %model_graft_by_name; } # load a model from file. See comments around raw_models attribute for explanations sub load { my $self = shift; my $model_name = shift; # model name like Foo::Bar my $load_file = shift; # model file (override model name), used for tests $loader_logger->debug("called on model $model_name"); my $path_load_file = $self->find_model_file_in_inc($model_name, $load_file); my %models_by_name; # Searches $load_file in @INC and returns an array containing the # names of the loaded classes my $model = $self->_load_model_file($path_load_file->absolute); my @loaded_classes = $self->_merge_model_in_hash( \%models_by_name, $model, $path_load_file ); $self->store_raw_model( $model_name, dclone( \%models_by_name ) ); foreach my $name ( keys %models_by_name ) { my $data = $self->normalize_class_parameters( $name, $models_by_name{$name} ); $loader_logger->debug("Store normalized model $name"); $self->store_normalized_model( $name, $data ); } my %model_graft_by_name = $self->load_model_plugins(sort keys %models_by_name); # store snippet. May be used later foreach my $name (keys %model_graft_by_name) { # store snippet for later usage $loader_logger->trace("storing snippet for model $name"); $self->add_snippet($model_graft_by_name{$name}); } # check if a snippet is available for this class foreach my $snippet ( $self->all_snippets ) { my $class_to_merge = $snippet->{name}; next unless $models_by_name{$class_to_merge}; $self->augment_config_class_really( $class_to_merge, $snippet ); } # return the list of classes found in $load_file. Respecting the order of the class # declaration is important for Config::Model::Itself so the class are written back # in the same order. return @loaded_classes; } # New subroutine "_load_model_in_hash" extracted - Fri Apr 12 17:29:56 2013. # sub _merge_model_in_hash { my ( $self, $hash_ref, $model, $load_file ) = @_; my @names; foreach my $config_class_info (@$model) { my %data = ref $config_class_info eq 'HASH' ? %$config_class_info : ref $config_class_info eq 'ARRAY' ? @$config_class_info : croak "load $load_file: config_class_info is not a ref"; my $config_class_name = $data{name} or croak "load: missing config class name in $load_file"; # check config class parameters and fill %model $hash_ref->{$config_class_name} = \%data; push @names, $config_class_name; } return @names; } sub _load_model_file { my ( $self, $load_file ) = @_; $loader_logger->info("load model $load_file"); my $err_msg = ''; # do searches @INC if the file path is not absolute my $model = do $load_file; unless ($model) { if ($@) { $err_msg = "couldn't parse $load_file: $@"; } elsif ( not defined $model ) { $err_msg = "couldn't do $load_file: $!" } else { $err_msg = "couldn't run $load_file"; } } elsif ( ref($model) ne 'ARRAY' ) { $model = [$model]; } Config::Model::Exception::ModelDeclaration->throw( message => "load error: $err_msg" ) if $err_msg; return $model; } sub augment_config_class { my ( $self, %augment_data ) = @_; # %args must contain existing class name to augment # plus other data to merge to raw model my $config_class_name = delete $augment_data{name} || croak "augment_config_class: missing class name"; $self->augment_config_class_really( $config_class_name, \%augment_data ); return; } sub augment_config_class_really { my ( $self, $config_class_name, $augment_data ) = @_; my $orig_model = $self->normalized_model($config_class_name); croak "unknown class to augment: $config_class_name" unless defined $orig_model; my $model_addendum = $self->normalize_class_parameters( $config_class_name, dclone($augment_data) ); my $merge = Hash::Merge->new('RIGHT_PRECEDENT'); my $new_model = $merge->merge( $orig_model, $model_addendum ); # remove duplicates in element_list and accept_list while keeping order foreach my $list_name (qw/element_list accept_list/) { my %seen; my @newlist; foreach my $elt ( @{ $new_model->{$list_name} } ) { push @newlist, $elt unless $seen{$elt}; $seen{$elt} = 1; } $new_model->{$list_name} = \@newlist; } $self->store_normalized_model( $config_class_name => $new_model ); return; } sub model { my $self = shift; my $config_class_name = shift || die "Model::get_model: missing config class name argument"; $self->load($config_class_name) unless $self->normalized_model_exists($config_class_name); if ( not $self->model_defined($config_class_name) ) { $loader_logger->debug("creating model $config_class_name"); my $model = $self->merge_included_class($config_class_name); $self->_store_model( $config_class_name, $model ); } return $self->_get_model($config_class_name) || croak "get_model error: unknown config class name: $config_class_name"; } sub get_model { my ($self,$model) = @_; carp "get_model is deprecated in favor of get_model_clone"; return $self->get_model_clone($model); } sub get_model_clone { my ($self,$model) = @_; return dclone($self->model($model)); } # internal sub get_model_doc { my ( $self, $top_class_name, $done ) = @_; $done //= {}; if ( not defined $self->normalized_model($top_class_name) ) { eval { $self->model($top_class_name); }; if ($@) { my $e = $@; if ($e->isa('Config::Model::Exception::ModelDeclaration')) { Config::Model::Exception::Fatal->throw( message => "Unknown configuration class : $top_class_name ($@)" ); } else { $e->rethrow; } } } my @classes = ($top_class_name); my %result; while (@classes) { my $class_name = shift @classes; next if $done->{$class_name} ; my $c_model = $self->model($class_name) || croak "get_model_doc model error : unknown config class name: $class_name"; my $full_name = "Config::Model::models::$class_name"; my %see_also; my @pod = ( # Pod::Weaver compatibility "# PODNAME: $full_name", "# ABSTRACT: Configuration class " . $class_name, '', # assume utf8 for all docs "=encoding utf8", '', # plain old pod compatibility "=head1 NAME", '', "$full_name - Configuration class " . $class_name, '', "=head1 DESCRIPTION", '', "Configuration classes used by L", '' ); my %legalese; my $i = 0; my $class_desc = $c_model->{class_description}; push @pod, $class_desc, '' if defined $class_desc; my @elt = ( "=head1 Elements", '' ); foreach my $elt_name ( @{ $c_model->{element_list} } ) { my $elt_info = $c_model->{element}{$elt_name}; my $summary = $elt_info->{summary} || ''; $summary &&= " - $summary"; push @elt, "=head2 $elt_name$summary", ''; push @elt, $self->get_element_description($elt_info), ''; foreach ( $elt_info, $elt_info->{cargo} ) { if ( my $ccn = $_->{config_class_name} ) { push @classes, $ccn; $see_also{$ccn} = 1; } if ( my $migr = $_->{migrate_from} ) { push @elt, $self->get_migrate_doc( $elt_name, 'is migrated with', $migr ); } if ( my $migr = $_->{migrate_values_from} ) { push @elt, "Note: $elt_name values are migrated from '$migr'", ''; } if ( my $comp = $_->{compute} ) { push @elt, $self->get_migrate_doc( $elt_name, 'is computed with', $comp ); } } } foreach my $what (qw/author copyright license/) { my $item = $c_model->{$what}; push @{ $legalese{$what} }, $item if $item; } my @end; foreach my $what (qw/author copyright license/) { next unless @{ $legalese{$what} || [] }; push @end, "=head1 " . uc($what), '', '=over', '', ( map { ( "=item $_", '' ); } map { ref $_ ? @$_ : $_ } @{ $legalese{$what} } ), '', '=back', ''; } my @see_also = ( "=head1 SEE ALSO", '', "=over", '', "=item *", '', "L", '', ( map { ( "=item *", '', "L", '' ); } sort keys %see_also ), "=back", '' ); $result{$full_name} = join( "\n", @pod, @elt, @see_also, @end, '=cut', '' ) . "\n"; $done->{$class_name} = 1; } return \%result; } # # New subroutine "get_migrate_doc" extracted - Tue Jun 5 13:31:20 2012. # sub get_migrate_doc { my ( $self, $elt_name, $desc, $migr ) = @_; my $mv = $migr->{variables}; my $mform = $migr->{formula}; if ( $mform =~ /\n/) { $mform =~ s/^/ /mg; $mform = "\n\n$mform\n\n"; } else { $mform = "'C<$mform>' " } my $mdoc = "Note: $elt_name $desc ${mform}and with: \n\n=over\n\n=item *\n\n" . join( "\n\n=item *\n\n", map { qq!C<\$$_> => C<$mv->{$_}>! } sort keys %$mv ); if ( my $rep = $migr->{replace} ) { $mdoc .= "\n\n=item *\n\n" . join( "\n\n=item *\n\n", map { qq!C<\$replace{$_}> => C<$rep->{$_}>! } sort keys %$rep ); } $mdoc .= "\n\n=back\n\n"; return ( $mdoc, '' ); } sub get_element_description { my ( $self, $elt_info ) = @_; my $type = $elt_info->{type}; my $cargo = $elt_info->{cargo}; my $vt = $elt_info->{value_type}; my $of = ''; my $cargo_type = $cargo->{type}; my $cargo_vt = $cargo->{value_type}; $of = " of " . ( $cargo_vt or $cargo_type ) if defined $cargo_type; my $ccn = $elt_info->{config_class_name} || $cargo->{config_class_name}; $of .= " of class L<$ccn|Config::Model::models::$ccn> " if $ccn; my $desc = $elt_info->{description} || ''; if ($desc) { $desc .= '.' if $desc =~ /\w$/; $desc .= ' ' unless $desc =~ /\s$/; } if ( my $status = $elt_info->{status} ) { $desc .= 'B<' . ucfirst($status) . '> '; } my $info = $elt_info->{mandatory} ? 'Mandatory. ' : 'Optional. '; $info .= "Type " . ( $vt || $type ) . $of . '. '; foreach my $name (qw/choice/) { my $item = $elt_info->{$name}; next unless defined $item; $info .= "$name: '" . join( "', '", @$item ) . "'. "; } my @default_info = (); # assemble in over item for string value_type foreach my $name (qw/default upstream_default/) { my $item = $elt_info->{$name}; next unless defined $item; push @default_info, [$name, $item] ; } my $elt_help = $self->get_element_value_help($elt_info); # breaks pod if $info is multiline my $ret = $desc . "I< $info > "; if (@default_info) { $ret .= "\n\n=over 4\n\n"; for ( @default_info) { $ret .= "=item $_->[0] value :\n\n$_->[1]\n\n"; } $ret .= "=back\n\n"; } $ret.= $elt_help; return $ret; } sub get_element_value_help { my ( $self, $elt_info ) = @_; my $help = $elt_info->{help}; return '' unless defined $help; my $help_text = "\n\nHere are some explanations on the possible values:\n\n=over\n\n"; foreach my $v ( sort keys %$help ) { $help_text .= "=item '$v'\n\n$help->{$v}\n\n"; } return $help_text . "=back\n\n"; } sub generate_doc { my ( $self, $top_class_name, $dir_str, $done ) = @_; $done //= {} ; my $res = $self->get_model_doc($top_class_name, $done); if ( defined $dir_str and $dir_str ) { foreach my $class_name ( sort keys %$res ) { my $dir = path($dir_str); $dir->mkpath() unless $dir->exists; my $file_path = $class_name; $file_path =~ s!::!/!g; my $pl_file = $dir->child("$file_path.pl"); $pl_file->parent->mkpath unless $pl_file->parent->exists; my $pod_file = $dir->child("$file_path.pod"); my $old = ''; if ($pod_file->exists ) { $old = $pod_file->slurp_utf8; } if ( $old ne $res->{$class_name} ) { $pod_file->spew_utf8( $res->{$class_name} ); say "Wrote documentation in $pod_file"; } } } else { foreach my $class_name ( sort keys %$res ) { print "########## $class_name ############ \n\n"; print $res->{$class_name}; } } return; } sub get_element_model { my $self = shift; my $config_class_name = shift || die "Model::get_element_model: missing config class name argument"; my $element_name = shift || die "Model::get_element_model: missing element name argument"; my $model = $self->model($config_class_name); my $element_m = $model->{element}{$element_name} || croak "get_element_model error: unknown element name: $element_name"; return dclone($element_m); } # returns a hash ref containing the raw model, i.e. before expansion of # multiple keys (i.e. [qw/a b c/] => ... ) # internal. For now ... sub get_normalized_model { my $self = shift; my $config_class_name = shift; $self->load($config_class_name) unless defined $self->normalized_model($config_class_name); my $normalized_model = $self->normalized_model($config_class_name) || croak "get_normalized_model error: unknown config class name: $config_class_name"; return dclone($normalized_model); } sub get_element_name ($self, %args) { my $class = $args{class} || croak "get_element_name: missing 'class' parameter"; if (delete $args{for}) { carp "get_element_name: 'for' parameter is deprecated"; } my $model = $self->model($class); my @result; # this is a bit convoluted, but the order of the returned element # must respect the order of the elements declared in the model by # the user foreach my $elt ( @{ $model->{element_list} } ) { my $elt_data = $model->{element}{$elt}; my $l = $elt_data->{level} || get_default_property('level'); push @result, $elt if $l ne 'hidden' ; } return wantarray ? @result : join( ' ', @result ); } sub get_element_property ($self, %args) { my $elt = $args{element} || croak "get_element_property: missing 'element' parameter"; my $prop = $args{property} || croak "get_element_property: missing 'property' parameter"; my $class = $args{class} || croak "get_element_property:: missing 'class' parameter"; my $model = $self->model($class); # must take into account 'accept' model parameter if ( not defined $model->{element}{$elt} ) { $logger->debug("test accept for class $class elt $elt prop $prop"); foreach my $acc_re ( @{ $model->{accept_list} } ) { return $model->{accept}{$acc_re}{$prop} || get_default_property($prop) if $elt =~ /^$acc_re$/; } } return $self->model($class)->{element}{$elt}{$prop} || get_default_property($prop); } sub list_class_element { my $self = shift; my $pad = shift || ''; my $res = ''; foreach my $class_name ( $self->normalized_model_names ) { $res .= $self->list_one_class_element($class_name); } return $res; } sub list_one_class_element { my $self = shift; my $class_name = shift; my $pad = shift || ''; my $res = $pad . "Class: $class_name\n"; my $c_model = $self->normalized_model($class_name); my $elts = $c_model->{element_list}; # array ref return $res unless defined $elts and @$elts; foreach my $elt_name (@$elts) { my $type = $c_model->{element}{$elt_name}{type}; $res .= $pad . " - $elt_name ($type)\n"; } return $res; } __PACKAGE__->meta->make_immutable; 1; # ABSTRACT: a framework to validate, migrate and edit configuration files __END__ =pod =encoding UTF-8 =head1 NAME Config::Model - a framework to validate, migrate and edit configuration files =head1 VERSION version 2.149 =head1 SYNOPSIS =head2 Perl program to use an existing model use Config::Model qw(cme); # load, modify and save popcon configuration file cme('popcon')->modify("PARTICIPATE=yes"); =head2 Command line to use an existing model # with App::Cme cme modify popcon 'PARTICIPATE=yes' =head2 Perl program with a custom model use Config::Model; # create new Model object my $model = Config::Model->new() ; # Config::Model object # create config model. A more complex model should be stored in a # file in lib/Config/Model/models. Then, run cme as explained below $model ->create_config_class ( name => "MiniModel", element => [ [qw/foo bar baz/ ] => { type => 'leaf', value_type => 'uniline' }, ], rw_config => { backend => 'IniFile', auto_create => 1, config_dir => '.', file => 'mini.ini', } ) ; # create instance (Config::Model::Instance object) my $instance = $model->instance (root_class_name => 'MiniModel'); # get configuration tree root my $cfg_root = $instance -> config_root ; # C::M:Node object # load some dummy data $cfg_root -> load("bar=BARV foo=FOOV baz=BAZV") ; # write new ini file $instance -> write_back; # now look for new mini.ini file un current directory =head2 Create a new model file and use it $ mkdir -p lib/Config/Model/models/ $ echo "[ { name => 'MiniModel', \ element => [ [qw/foo bar baz/ ] => { type => 'leaf', value_type => 'uniline' }, ], \ rw_config => { backend => 'IniFile', auto_create => 1, \ config_dir => '.', file => 'mini.ini', \ } \ } \ ] ; " > lib/Config/Model/models/MiniModel.pl # require App::Cme $ cme modify -try MiniModel -dev bar=BARV foo=FOOV baz=BAZV $ cat mini.ini Note that model creation is easier running C with L and L. =head1 DESCRIPTION Config::Model enables a project developer to provide an interactive configuration editor (graphical, curses based or plain terminal) to users. To provide these tools, Config::Model needs: =over =item * A description of the structure and constraints of the project's configuration (fear not, a GUI is available with L) =item * A module to read and write configuration data (aka a backend class). =back With the elements above, Config::Model generates interactive configuration editors (with integrated help and data validation). These editors can be graphical (with L), curses based (with L) or based on ReadLine. Smaller models targeted for configuration upgrades can also be created: =over =item * only upgrade and migration specifications are required =item * unknown parameters can be accepted =back A command line is provided to perform configuration upgrade with a single command. =head2 How does this work ? Using this project, a typical configuration editor/validator/upgrader is made of 3 parts : GUI <--------> |---------------| CursesUI <---> | |---------| | | | Model | | ShellUI <----> | |---------| |<-----read-backend------- |-------------| | |----write-backend-------> | config file | FuseUI <-----> | Config::Model | |-------------| |---------------| =over =item 1. A reader and writer that parse the configuration file and transform its data into a tree representation within Config::Model. The values contained in this configuration tree can be written back in the configuration file(s). =item 2. A validation engine which is in charge of validating the content and structure of configuration stored in the configuration tree. This validation engine follows the structure and constraint declared in a configuration model. This model is a kind of schema for the configuration tree. =item 3. A user interface to modify the content of the configuration tree. A modification is validated immediately by the validation engine. =back The important part is the configuration model used by the validation engine. This model can be created or modified with a graphical editor (Config::Model::Iself). =head1 Question you may ask yourself =head2 Don't we already have some configuration validation tools ? You're probably thinking of tools like webmin. Yes, these tools exist and work fine, but they have their set of drawbacks. Usually, the validation of configuration data is done with a script which performs semantic validation and often ends up being quite complex (e.g. 2500 lines for Debian's xserver-xorg.config script which handles C file). In most cases, the configuration model is expressed in instructions (whatever programming language is used) and interspersed with a lot of processing to handle the actual configuration data. =head2 What's the advantage of this project ? Config::Model projects provide a way to get a validation engine where the configuration model is completely separated from the actual processing instructions. A configuration model can be created and modified with the graphical interface provide by L. The model is saved in a declarative form (currently, a Perl data structure). Such a model is easier to maintain than a lot of code. The model specifies: =over =item * The structure of the configuration data (which can be queried by generic user interfaces) =item * The properties of each element (boundaries check, integer or string, enum like type, default value ...) =item * The targeted audience (beginner, advanced, master) =item * The on-line help =back So, in the end: =over =item * Maintenance and evolution of the configuration content is easier =item * User sees a *common* interface for *all* programs using this project. =item * Upgrade of configuration data is easier and sanity check is performed during the upgrade. =item * Audit of configuration is possible to check what was modified by the user compared to default values =back =head2 What about the user interface ? L interface can be: =over =item * a shell-like interface (plain or based on Term::ReadLine). =item * Graphical with L (Perl/Tk interface). =item * based on curses with L. This interface can be handy if your X server is down. =item * Through a virtual file system where every configuration parameter is mapped to a file. (Linux only) =back All these interfaces are generated from the configuration model. And configuration model can be created or modified with a graphical user interface (with C once L is installed) =head2 What about configuration data storage ? Since the syntax of configuration files vary wildly form one application to another, people who want to use this framework may have to provide a dedicated parser/writer. To help with this task, this project provides writer/parsers for common format: INI style file and perl file. With the additional Config::Model::Backend::Augeas, Augeas library can be used to read and write some configuration files. See http://augeas.net for more details. =head2 Is there an example of a configuration model ? The "example" directory contains a configuration model example for C file. This example includes a small program that use this model to show some ways to extract configuration information. =head1 Mailing lists For more question, please send a mail to: config-model-users at lists.sourceforge.net =head1 Suggested reads to start =head2 Beginners =over =item * L =item * L =back =head2 Advanced =over =item * L: This doc and its siblings describes all parameters available to create a model. These are the parameters available in the GUI launched by C command. =item * L =back =head2 Masters use the source, Luke =head1 STOP The documentation below is quite detailed and is more a reference doc regarding C class. For an introduction to model creation, please check: L =head1 Storage backend, configuration reader and writer See L for details =head1 Validation engine C provides a way to get a validation engine from a set of rules. This set of rules is called the configuration model. =head1 User interface The user interface uses some parts of the API to set and get configuration values. More importantly, a generic user interface needs to analyze the configuration model to be able to generate at run-time relevant configuration screens. A command line interface is provided in this module. Curses and Tk interfaces are provided by L and L. =head1 Constructor my $model = Config::Model -> new ; creates an object to host your model. =head2 Constructor parameters =over =item log_level Specify minimal log level. Default is C. Can be C, C or C to get more logs. Can also be C to get less traces. This parameter is used to override the log level specified in log configuration file. =back =head1 Configuration Model To validate a configuration tree, we must create a configuration model that defines all the properties of the validation engine you want to create. The configuration model is expressed in a declarative form (i.e. a Perl data structure which should be easier to maintain than a lot of code) Each configuration class may contain a set of: =over =item * node elements that refer to another configuration class =item * value elements that contain actual configuration data =item * list or hash elements that also contain several node or value elements =back The structure of your configuration tree is shaped by the a set of configuration classes that are used in node elements, The structure of the configuration data must be based on a tree structure. This structure has several advantages: =over =item * Unique path to get to a node or a leaf. =item * Simpler exploration and query =item * Simple hierarchy. Deletion of configuration items is simpler to grasp: when you cut a branch, all the leaves attached to that branch go down. =back But using a tree has also some drawbacks: =over 4 =item * A complex configuration cannot be mapped on a tree. Some more relation between nodes and leaves must be added. =item * A configuration may actually be structured as a graph instead as a tree (for instance, any configuration that maps a service to a resource). The graph relation must be decomposed in a tree with special I relations that complete the tree to form a graph. See L =back Note: a configuration tree is a tree of objects. The model is declared with classes. The classes themselves have relations that closely match the relation of the object of the configuration tree. But the class need not to be declared in a tree structure (always better to reuse classes). But they must be declared as a DAG (directed acyclic graph). See also LMore on DAGs> Each configuration class declaration specifies: =over =item * The C of the class (mandatory) =item * A C used in user interfaces (optional) =item * Optional include specification to avoid duplicate declaration of elements. =item * The class elements =back Each element specifies: =over =item * Most importantly, the type of the element (mostly C, or C) =item * The properties of each element (boundaries, check, integer or string, enum like type ...) =item * The default values of parameters (if any) =item * Whether the parameter is mandatory =item * Targeted audience (beginner, advance, master), i.e. the level of expertise required to tinker a parameter (to hide expert parameters from newbie eyes) =item * On-line help (for each parameter or value of parameter) =back See L for details on how to declare a configuration class. Example: $ cat lib/Config/Model/models/Xorg.pl [ { name => 'Xorg', class_description => 'Top level Xorg configuration.', include => [ 'Xorg::ConfigDir'], element => [ Files => { type => 'node', description => 'File pathnames', config_class_name => 'Xorg::Files' }, # snip ] }, { name => 'Xorg::DRI', element => [ Mode => { type => 'leaf', value_type => 'uniline', description => 'DRI mode, usually set to 0666' } ] } ]; =head1 Configuration instance methods A configuration instance is created from a model and is the starting point of a configuration tree. =head2 instance An instance must be created with a model name (using the root class name) or an application name (as shown by "L C" command). For example: my $model = Config::Model->new() ; $model->instance( application => 'approx'); Or: my $model = Config::Model->new() ; # note that the model class is slightly different compared to # application name $model->instance( root_class_name => 'Approx'); A custom configuration class can also be used with C parameter: my $model = Config::Model->new() ; # create_config_class is described below $model ->create_config_class ( name => "SomeRootClass", element => [ ... ] ) ; # instance name is 'default' my $inst = $model->instance (root_class_name => 'SomeRootClass'); You can create several separated instances from a model using C option: # instance name is 'default' my $inst = $model->instance ( root_class_name => 'SomeRootClass', name => 'test1' ); Usually, model files are loaded automatically using a path matching C (e.g. configuration class C is stored in C. You can choose to specify the file containing the model with C parameter. This is mostly useful for tests. The C method can also retrieve an instance that has already been created: my $inst = $model->instance( name => 'test1' ); =head2 get_instance Retrieve an existing instance using its name. my $inst = $model->get_instance('test1' ); =head2 has_instance Check if an instance name already exists my $maybe = $model->has_instance('test1'); =head2 cme This method is syntactic sugar for short program. It creates a new C object and returns a new instance. C arguments are passed to L method, except C. Like L command, C functions accepts C parameters. When this argument is true, the instance is created with C 'no'>. Hence bad values are stored in C and must be corrected before saving back the data. =head1 Configuration class A configuration class is made of series of elements which are detailed in L. Whatever its type (node, leaf,... ), each element of a node has several other properties: =over =item level Level is C, C or C. The level is used to set how configuration data is presented to the user in browsing mode. C elements are shown to the user no matter what. C elements are well, hidden. Their purpose is explained with the I notion. =item status Status is C, C or C (default). Using a deprecated element raises a warning. Using an obsolete element raises an exception. =item description Description of the element. This description is used while generating user interfaces. =item summary Summary of the element. This description is used while generating a user interfaces and may be used in comments when writing the configuration file. =item class_description Description of the configuration class. This description is used while generating user interfaces. =item generated_by Mention with a descriptive string if this class was generated by a program. This parameter is currently reserved for L model editor. =item include Include element description from another class. include => 'AnotherClass' , or include => [qw/ClassOne ClassTwo/] In a configuration class, the order of the element is important. For instance if C is warped by C, you must declare C element before C. When including another class, you may wish to insert the included elements after a specific element of your including class: # say AnotherClass contains element xyz include => 'AnotherClass' , include_after => "foo" , element => [ bar => ... , foo => ... , baz => ... ] Now the element of your class are: ( bar , foo , xyz , baz ) Note that include may not clobber an existing element. =item include_backend Include read/write specification from another class. include_backend => 'AnotherClass' , or include_backend => [qw/ClassOne ClassTwo/] =back Note that include may not clobber an existing read/write specification. =head2 create_config_class This method creates configuration classes. The parameters are described above and are forwarded to L constructor. See L for more details on configuration class parameters. Example: my $model = Config::Model -> new ; $model->create_config_class ( config_class_name => 'SomeRootClass', description => [ X => 'X-ray' ], level => [ 'tree_macro' => 'important' ] , class_description => "SomeRootClass description", element => [ ... ] ) ; For convenience, C and C parameters can also be declared within the element declaration: $model->create_config_class ( config_class_name => 'SomeRootClass', class_description => "SomeRootClass description", 'element' => [ tree_macro => { level => 'important'}, X => { description => 'X-ray', } , ] ) ; =head1 Load predeclared model You can also load predeclared model. =head2 load( ) This method opens the model directory and execute a C<.pl> file containing the model declaration, This perl file must return an array ref to declare models. E.g.: [ [ name => 'Class_1', element => [ ... ] ], [ name => 'Class_2', element => [ ... ] ] ]; do not put C<1;> at the end or C will not work When a model name contain a C<::> (e.g C), C looks for a file named C. This method also searches in C directory for additional model information. Model snippet found there are loaded with L. Returns a list containing the names of the loaded classes. For instance, if C contains a model for C and C, C returns C<( 'Foo::Bar' , 'Foo::Bar2' )>. =head2 augment_config_class (name => '...', class_data ) Enhance the feature of a configuration class. This method uses the same parameters as L. See L for more details on creating model plugins. =head1 Model query =head2 model Returns a hash containing the model declaration of the passed model name. Do not modify the content of the returned data structure. my $cloned = $model->model('Foo'); =head2 get_model_clone Like C, returns a hash containing the model declaration of the passed model name, this time in a deep clone of the data structure. my $cloned = $model->get_model_clone('Foo'); =head2 generate_doc ( top_class_name , directory , [ \%done ] ) Generate POD document for configuration class top_class_name and all classes used by top_class_name, and write them in specified directory. C<\%done> is an optional reference to a hash used to avoid writing twice the same documentation when this method is called several times. =head2 get_element_model( config_class_name , element) Return a hash containing the model declaration for the specified class and element. =head2 get_element_name( class => Foo ) Get all names of the elements of class C. =head2 get_element_property Returns the property of an element from the model. Parameters are: =over =item class =item element =item property =back =head2 list_class_element Returns a string listing all the class and elements. Useful for debugging your configuration model. =head1 Error handling Errors are handled with an exception mechanism. When a strongly typed Value object gets an authorized value, it raises an exception. If this exception is not caught, the programs exits. See L for details on the various exception classes provided with C. =head1 Logging See L =head2 initialize_log4perl This method can be called to load L configuration from C<~/.log4config-model>, or from C files or from L. Accepts C parameter with a list of log classes that are added to the log4perl configuration read above. For instance, with C<< verbose => 'Loader' >>, log4perl is initialised with log4perl.logger.Verbose.Loader = INFO, PlainMsgOnScreen Likewise, with C<< verbose => [ 'Loader', 'Foo' ] >>, log4perl is initialised with: log4perl.logger.Verbose.Loader = INFO, PlainMsgOnScreen log4perl.logger.Verbose.Foo = INFO, PlainMsgOnScreen Currently, this module supports only C as verbose parameters. =head1 BUGS Given Murphy's law, the author is fairly confident that you will find bugs or miss some features. Please report them to https://github.com/dod38fr/config-model/issues The author will be notified, and then you'll automatically be notified of progress on your bug. =head1 FEEDBACK Feedback from users are highly desired. If you find this module useful, please share your use cases, success stories with the author or with the config-model- users mailing list. =head1 PROJECT FOUNDER Dominique Dumont, "ddumont@cpan.org" =head1 CREDITS Contributors to this project are listed in alphabetical order: Harley Pig Ilya Arosov Jose Luis Perez Diez Krzysztof Tyszecki Mathieu Arnold Mohammad S Anwar Topi Miettinen Many thanks for your help =head1 SEE ALSO L, L L =head2 Model elements The arrow shows inheritance between classes =over =item * L <- L =item * L <- L <- L =item * L <- L <- L =item * L <- L =item * L <- L =item * L <- L =back =head2 command line L. =head2 Read and write backends =over =item * L <- L =item * L <- L =item * L <- L =item * L <- L =back =head2 Model utilities =over =item * L =item * L: Used by C object =item * L =item * L =item * L =item * L =item * L =item * L =item * L =item * L =item * L: Search element in configuration model. =item * L =item * L: Search string or regexp in configuration tree. =item * L =item * L =item * L =item * L =back =head2 Test framework =over =item * L =back =head1 AUTHOR Dominique Dumont =head1 COPYRIGHT AND LICENSE This software is Copyright (c) 2005-2022 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 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 * 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 smoke testers 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 Config-Model-2.149/t/0000755000175000017500000000000014170053137012702 5ustar domidomiConfig-Model-2.149/t/README.md0000644000175000017500000000176514170053137014172 0ustar domidomi## Running the tests All tests can be run in parrallel with prove -j8 t/ ### Test options Most tests can be run with the options provided by [Config::Model::Tester::Setup](https://metacpan.org/pod/Config::Model::Tester::Setup): * `-trace`: show more information * `-error`: show stack stace in case of error * `-log`: Enable logs (you may need to tweak `~/.log4config-model` to get more trace. See [cme/Logging](https://metacpan.org/pod/distribution/App-Cme/bin/cme#Logging) for more details. ### model_tests.t This test is set of subtests made of test cases. It accepts arguments to limit the test to one subtest and one test case: perl t/model_test.t [ --log ] [--error] [--trace] [ subtest [ test_case ] ] See [Config::Model::Tester](https://metacpan.org/pod/Config::Model::Tester) for more details. ### Running with prove You can run all tests with prove -j8 t/ To run with local files: prove -l -j8 t/ You can pass parameter to test files with: prove -l t/ :: --log Config-Model-2.149/t/model_tests.d/0000755000175000017500000000000014170053137015446 5ustar domidomiConfig-Model-2.149/t/model_tests.d/layer-test-conf.pl0000644000175000017500000000307714170053137021026 0ustar domidomi# # This file is part of Config-Model # # This software is Copyright (c) 2005-2022 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 use strict; use warnings; my $home_for_test = '/home/joe' ; Config::Model::BackendMgr::_set_test_home($home_for_test) ; my @config_classes = ({ 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' ] }, ], 'rw_config' => { 'backend' => 'perl_file', 'config_dir' => '~/foo', 'file' => 'config.pl', 'default_layer' => { 'config_dir' => '/etc', 'file' => 'foo-config.pl' } } }); my @tests = ({ 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'}, ] }); return { model_to_test => "LayeredClass", config_classes => \@config_classes, home_for_test => $home_for_test, tests => \@tests }; Config-Model-2.149/t/model_tests.d/backend-shellvar-test-conf.pl0000644000175000017500000000231014170053137023104 0ustar domidomi# # This file is part of Config-Model # # This software is Copyright (c) 2005-2022 by Dominique Dumont. # # This is free software, licensed under: # # The GNU Lesser General Public License, Version 2.1, February 1999 # # test shellvar backend use Config::Model::BackendMgr; use strict; use warnings; my @config_classes = ({ name => "Shelly", element => [ [qw/foo bar/], { 'value_type' => 'uniline', 'type' => 'leaf', }, ], 'rw_config' => { backend => 'ShellVar', config_dir => '/etc', file => 'foo.conf', } }); my @tests = ( { # mini (test for Debian #719256) name => 'debian-719256', check => [ foo => 'ok', bar => "with space" ], }, { # data is written in file not using canonical order name => 'keep-order', file_contents_like => { "/etc/foo.conf" => [ qr/bar="with space"\nfoo="ok"/m ] , } } ); return { model_to_test => "Shelly", home_for_test => '/home/joe', conf_file_name => 'foo.conf', conf_dir => '/etc', config_classes => \@config_classes, tests => \@tests }; Config-Model-2.149/t/model_tests.d/multistrap-test-conf.pl0000644000175000017500000000401714170053137022111 0ustar domidomi# # This file is part of Config-Model # # This software is Copyright (c) 2005-2022 by Dominique Dumont. # # This is free software, licensed under: # # The GNU Lesser General Public License, Version 2.1, February 1999 # use strict; use warnings; my $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 my @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', log4perl_load_warnings => [ [ 'User', warn => qr/deprecated/ ] , [ 'User' , ( warn => qr/skipping/) x 2 ] ], }, ); return { model_to_test => "Multistrap", tests => \@tests }; Config-Model-2.149/t/model_tests.d/multi-ini-test-conf.pl0000644000175000017500000000360014170053137021611 0ustar domidomi# # This file is part of Config-Model # # This software is Copyright (c) 2005-2022 by Dominique Dumont. # # This is free software, licensed under: # # The GNU Lesser General Public License, Version 2.1, February 1999 # use strict; use warnings; # test inifile backend with multiple ini files # create minimal model to test ini file backend. # this class is used by MultiMiniIni class below my @config_classes = ({ name => 'MultiIniTest::Class', element => [ int_with_max => {qw/type leaf value_type integer max 10/}, ], rw_config => { backend => 'IniFile', config_dir => '/etc/', file => '&index.conf', auto_create => 1, }, }); push @config_classes, { name => 'MultiMiniIni', element => [ service => { type => 'hash', index_type => 'string', # require to trigger load of bar.conf default_keys => 'bar', cargo => { type => 'node', config_class_name => 'MultiIniTest::Class' } }, ], rw_config => { backend => 'perl', config_dir => '/etc/', file => 'service.pl', auto_create => 1, }, }; # the test suite my @tests = ( { name => 'max-overflow', load_check => 'no', # work only with Config::Model > 2.094 because of an obscure # initialisation bug occuring while loading a bad value in # a sub-node (thanks systemd) load => 'service:bar int_with_max=9', file_check_sub => sub { my $list_ref = shift ; # file added because of default bar key push @$list_ref, "/etc/service.pl" ; }, }, ); return { # specify the name of the class to test model_to_test => "MultiMiniIni", config_classes => \@config_classes, tests => \@tests }; Config-Model-2.149/t/model_tests.d/backend-json-test-conf.pl0000644000175000017500000000236614170053137022250 0ustar domidomi# # This file is part of Config-Model # # This software is Copyright (c) 2005-2022 by Dominique Dumont. # # This is free software, licensed under: # # The GNU Lesser General Public License, Version 2.1, February 1999 # use Config::Model::BackendMgr; use strict; use warnings; my @config_classes = ({ name => 'Host', element => [ [qw/ipaddr canonical alias/] => { type => 'leaf', value_type => 'uniline', }, dummy => {qw/type leaf value_type uniline default toto/}, ] }); push @config_classes, { name => 'Hosts', rw_config => { backend => 'json', config_dir => '/etc/', file => 'hosts.json', }, element => [ record => { type => 'list', cargo => { type => 'node', config_class_name => 'Host', }, }, ] }; my @tests = ( { name => 'basic', check => [ 'record:0 ipaddr' => '127.0.0.1', 'record:1 canonical' => 'bilbo' ] }, ); return { model_to_test => "Hosts", conf_dir => '/etc', conf_file_name => 'hosts.json', config_classes => \@config_classes, tests => \@tests }; Config-Model-2.149/t/model_tests.d/fstab-examples/0000755000175000017500000000000014170053137020361 5ustar domidomiConfig-Model-2.149/t/model_tests.d/fstab-examples/t10000644000175000017500000000322414170053137020631 0ustar domidomi# /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 Config-Model-2.149/t/model_tests.d/fstab-examples/t00000644000175000017500000000242214170053137020627 0ustar domidomi# /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 # see https://github.com/dod38fr/config-model/issues/30 UUID=CD5B-99E4 /boot/efi vfat ro,nosuid,nodev,noexec,noatime,noauto,umask=0077 0 1 Config-Model-2.149/t/model_tests.d/layer-examples/0000755000175000017500000000000014170053137020376 5ustar domidomiConfig-Model-2.149/t/model_tests.d/layer-examples/mini/0000755000175000017500000000000014170053137021332 5ustar domidomiConfig-Model-2.149/t/model_tests.d/layer-examples/mini/etc/0000755000175000017500000000000014170053137022105 5ustar domidomiConfig-Model-2.149/t/model_tests.d/layer-examples/mini/etc/foo-config.pl0000644000175000017500000000054714170053137024476 0ustar domidomi# # This file is part of Config-Model # # This software is Copyright (c) 2005-2022 by Dominique Dumont. # # This is free software, licensed under: # # The GNU Lesser General Public License, Version 2.1, February 1999 # use strict; use warnings; return { set_in_etc => 'system value', set_in_both => 'system value2', a_checklist => {qw/c 1 d 0 e 1/} }; Config-Model-2.149/t/model_tests.d/layer-examples/mini/home/0000755000175000017500000000000014170053137022262 5ustar domidomiConfig-Model-2.149/t/model_tests.d/layer-examples/mini/home/joe/0000755000175000017500000000000014170053137023037 5ustar domidomiConfig-Model-2.149/t/model_tests.d/layer-examples/mini/home/joe/foo/0000755000175000017500000000000014170053137023622 5ustar domidomiConfig-Model-2.149/t/model_tests.d/layer-examples/mini/home/joe/foo/config.pl0000644000175000017500000000053414170053137025426 0ustar domidomi# # This file is part of Config-Model # # This software is Copyright (c) 2005-2022 by Dominique Dumont. # # This is free software, licensed under: # # The GNU Lesser General Public License, Version 2.1, February 1999 # use strict; use warnings; { set_by_user => 'user value', set_in_both => 'user value2', a_checklist => {qw/e 0 f 1 g 1/} }; Config-Model-2.149/t/model_tests.d/backend-shellvar-examples/0000755000175000017500000000000014170053137022467 5ustar domidomiConfig-Model-2.149/t/model_tests.d/backend-shellvar-examples/debian-7192560000644000175000017500000000003214170053137024402 0ustar domidomifoo=ok bar = "with space" Config-Model-2.149/t/model_tests.d/backend-shellvar-examples/keep-order0000644000175000017500000000003014170053137024440 0ustar domidomibar="with space" foo=ok Config-Model-2.149/t/model_tests.d/backend-plainfile-test-conf.pl0000644000175000017500000000640414170053137023237 0ustar domidomi# # This file is part of Config-Model # # This software is Copyright (c) 2005-2022 by Dominique Dumont. # # This is free software, licensed under: # # The GNU Lesser General Public License, Version 2.1, February 1999 # # test plainfile backend package Config::Model::Backend::MyReader; ## no critic (Modules::RequireFilenameMatchesPackage) use Path::Tiny; use Test::More; use Mouse ; use strict; use warnings; extends 'Config::Model::Backend::Any'; sub my_log { note("plainfile backend test: @_"); } sub read { my $self = shift; my %args = @_; my $dir = $args{root}->child($args{config_dir}); foreach my $file ($dir->children()) { my_log("dummy read file $file"); my ($key,$elt) = split /\./,$file->basename; $args{object}->load("$elt:$key"); } return 1; } sub write { my $self = shift; my_log("dummy write called"); return 1; } # create minimal model to test plain file backend. # this class is used by MiniPlain class below my @config_classes = ({ element => [ list => { cargo => { type => 'leaf', value_type => 'uniline' }, type => 'list' }, a_string => { type => 'leaf', value_type => 'string' } ], name => 'PlainTest::Class', rw_config => { auto_create => '1', auto_delete => '1', backend => 'PlainFile', config_dir => 'debian', file_mode => '0755', file => '&index(-).&element(-).&element' } }); push @config_classes, { name => 'MiniPlain', element => [ [qw/install move/] => { type => 'hash', index_type => 'string', cargo => { type => 'node', value_type => 'uniline', config_class_name => 'PlainTest::Class' }, default_keys => [qw/foo bar/], }, ], rw_config => { backend => 'MyReader', config_dir => 'debian', auto_delete => '1', }, }; # the test suite my @tests = ( { name => 'with-index', check => [ # check a specific value stored in example file 'install:foo list:0' => "foo val1", 'move:bar list:0' => "bar val1", 'move:bar list:2' => "bar val3", ], file_mode => { 'debian/bar.install.list' => oct(755), 'debian/bar.move.list' => oct(755), 'debian/foo.install.list' => oct(755), } }, { # test file removal name => 'with-index-and-content-removal', data_from => 'with-index', load => 'install:bar list:.clear', file_check_sub => sub { shift @{$_[0]}; }, load2 => 'install:bar', }, { # test file removal name => 'with-index-and-removal', data_from => 'with-index', # push a value to force loading of install.bar file load => 'install:bar list:.push(pushed) - install~bar', file_check_sub => sub { shift @{$_[0]}; }, }, ); return { # specify where is the example file conf_dir => '', # specify the name of the class to test model_to_test => "MiniPlain", config_classes => \@config_classes, tests => \@tests }; Config-Model-2.149/t/model_tests.d/fstab-test-conf.pl0000644000175000017500000000166214170053137021007 0ustar domidomi# # This file is part of Config-Model # # This software is Copyright (c) 2005-2022 by Dominique Dumont. # # This is free software, licensed under: # # The GNU Lesser General Public License, Version 2.1, February 1999 # use strict; use warnings; my @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', "/" , }, }, ); return { model_to_test => "Fstab", conf_file_name => "fstab", conf_dir => "etc", tests => \@tests }; Config-Model-2.149/t/model_tests.d/backend-ini-test-conf.pl0000644000175000017500000000407214170053137022052 0ustar domidomi# # This file is part of Config-Model # # This software is Copyright (c) 2005-2022 by Dominique Dumont. # # This is free software, licensed under: # # The GNU Lesser General Public License, Version 2.1, February 1999 # use strict; use warnings; # test inifile backend # create minimal model to test ini file backend. # this class is used by MiniIni class below my @config_classes = ({ name => 'IniTest::Class', element => [ [qw/lista listb/] => { type => 'list', cargo => { type => 'leaf', value_type => 'uniline', }, }, ] }); push @config_classes, { name => 'MiniIni', element => [ [qw/foo bar/] => { type => 'list', cargo => { type => 'leaf', value_type => 'uniline', } }, baz => { qw/type leaf value_type uniline/, }, [qw/class1 class2/] => { type => 'node', config_class_name => 'IniTest::Class' } ], rw_config => { backend => 'IniFile', # specify where is the config file. this must match # the $conf_file_name and $conf_dir variable above config_dir => '/etc/', file => 'test.ini', file_mode => 'a=r,ug+w', auto_create => 1, }, }; # the test suite my @tests = ( { # test complex parameters name => 'complex', check => [ # check a specific value stored in example file baz => q!/bin/sh -c '[ "$(cat /etc/X11/default-display-manager 2>/dev/null)" = "/usr/bin/sddm" ]''! ], file_mode => { '/etc/test.ini' => oct(664) } }, ); return { # specify the name of the class to test model_to_test => "MiniIni", # specify where is the example file conf_file_name => 'test.ini', conf_dir => '/etc', config_classes => \@config_classes, tests => \@tests }; Config-Model-2.149/t/model_tests.d/multistrap-examples/0000755000175000017500000000000014170053137021466 5ustar domidomiConfig-Model-2.149/t/model_tests.d/multistrap-examples/from_scratch/0000755000175000017500000000000014170053137024140 5ustar domidomiConfig-Model-2.149/t/model_tests.d/multistrap-examples/from_scratch/usr/0000755000175000017500000000000014170053137024751 5ustar domidomiConfig-Model-2.149/t/model_tests.d/multistrap-examples/from_scratch/usr/share/0000755000175000017500000000000014170053137026053 5ustar domidomiConfig-Model-2.149/t/model_tests.d/multistrap-examples/from_scratch/usr/share/multistrap/0000755000175000017500000000000014170053137030257 5ustar domidomi././@LongLink0000644000000000000000000000015200000000000011601 Lustar rootrootConfig-Model-2.149/t/model_tests.d/multistrap-examples/from_scratch/usr/share/multistrap/crosschroot.confConfig-Model-2.149/t/model_tests.d/multistrap-examples/from_scratch/usr/share/multistrap/crosschroot0000644000175000017500000000210414170053137032547 0ustar domidomi# Example multistrap configuration file for a sid build chroot # Need to use cascading to select the toolchain for a cross arch. [General] arch= directory= # same as --tidy-up option if set to true cleanup=true # same as --no-auth option if set to true # keyring packages listed in each debootstrap will # still be installed. noauth=false # whether to add the /suite to be explicit about where apt # needs to look for packages. Default is false. explicitsuite=true # extract all downloaded archives (default is true) unpack=true # the order of sections is not important. # the debootstrap option determines which repository # is used to calculate the list of Priority: required packages. debootstrap=Debian Base aptsources=Debian Base # Lenny toolchains need -base from Lenny. [Base] packages=gcc-4.2-base source=http://ftp.uk.debian.org/debian keyring=debian-archive-keyring suite=lenny omitdebsrc=false [Debian] packages=dpkg-dev binutils-multiarch build-essential dpkg-cross aptitude source=http://ftp.uk.debian.org/debian keyring=debian-archive-keyring suite=unstable omitdebsrc=false Config-Model-2.149/t/model_tests.d/multistrap-examples/arm/0000755000175000017500000000000014170053137022245 5ustar domidomiConfig-Model-2.149/t/model_tests.d/multistrap-examples/arm/usr/0000755000175000017500000000000014170053137023056 5ustar domidomiConfig-Model-2.149/t/model_tests.d/multistrap-examples/arm/usr/share/0000755000175000017500000000000014170053137024160 5ustar domidomiConfig-Model-2.149/t/model_tests.d/multistrap-examples/arm/usr/share/multistrap/0000755000175000017500000000000014170053137026364 5ustar domidomiConfig-Model-2.149/t/model_tests.d/multistrap-examples/arm/usr/share/multistrap/crosschroot.conf0000644000175000017500000000210414170053137031600 0ustar domidomi# Example multistrap configuration file for a sid build chroot # Need to use cascading to select the toolchain for a cross arch. [General] arch= directory= # same as --tidy-up option if set to true cleanup=true # same as --no-auth option if set to true # keyring packages listed in each debootstrap will # still be installed. noauth=false # whether to add the /suite to be explicit about where apt # needs to look for packages. Default is false. explicitsuite=true # extract all downloaded archives (default is true) unpack=true # the order of sections is not important. # the debootstrap option determines which repository # is used to calculate the list of Priority: required packages. debootstrap=Debian Base aptsources=Debian Base # Lenny toolchains need -base from Lenny. [Base] packages=gcc-4.2-base source=http://ftp.uk.debian.org/debian keyring=debian-archive-keyring suite=lenny omitdebsrc=false [Debian] packages=dpkg-dev binutils-multiarch build-essential dpkg-cross aptitude source=http://ftp.uk.debian.org/debian keyring=debian-archive-keyring suite=unstable omitdebsrc=false Config-Model-2.149/t/model_tests.d/multistrap-examples/arm/home/0000755000175000017500000000000014170053137023175 5ustar domidomiConfig-Model-2.149/t/model_tests.d/multistrap-examples/arm/home/foo/0000755000175000017500000000000014170053137023760 5ustar domidomiConfig-Model-2.149/t/model_tests.d/multistrap-examples/arm/home/foo/my_arm.conf0000644000175000017500000000042214170053137026111 0ustar domidomi[GeneRal] inCLUde=/usr/share/multistrap/crosschroot.conf omitrequired=fAlse conFIGscript=config.sh setupscript=setup.sh [Toolchains] packages=g++-4.2-arm-linux-gnu linux-libc-dev-arm-cross source=http://www.emdebian.org/debian keyring=emdebian-archive-keyring suite=stable Config-Model-2.149/t/model_tests.d/multistrap-examples/igep0020/0000755000175000017500000000000014170053137022714 5ustar domidomiConfig-Model-2.149/t/model_tests.d/multistrap-examples/igep0020/usr/0000755000175000017500000000000014170053137023525 5ustar domidomiConfig-Model-2.149/t/model_tests.d/multistrap-examples/igep0020/usr/share/0000755000175000017500000000000014170053137024627 5ustar domidomiConfig-Model-2.149/t/model_tests.d/multistrap-examples/igep0020/usr/share/multistrap/0000755000175000017500000000000014170053137027033 5ustar domidomi././@LongLink0000644000000000000000000000014600000000000011604 Lustar rootrootConfig-Model-2.149/t/model_tests.d/multistrap-examples/igep0020/usr/share/multistrap/crosschroot.confConfig-Model-2.149/t/model_tests.d/multistrap-examples/igep0020/usr/share/multistrap/crosschroot.con0000644000175000017500000000210414170053137032101 0ustar domidomi# Example multistrap configuration file for a sid build chroot # Need to use cascading to select the toolchain for a cross arch. [General] arch= directory= # same as --tidy-up option if set to true cleanup=true # same as --no-auth option if set to true # keyring packages listed in each debootstrap will # still be installed. noauth=false # whether to add the /suite to be explicit about where apt # needs to look for packages. Default is false. explicitsuite=true # extract all downloaded archives (default is true) unpack=true # the order of sections is not important. # the debootstrap option determines which repository # is used to calculate the list of Priority: required packages. debootstrap=Debian Base aptsources=Debian Base # Lenny toolchains need -base from Lenny. [Base] packages=gcc-4.2-base source=http://ftp.uk.debian.org/debian keyring=debian-archive-keyring suite=lenny omitdebsrc=false [Debian] packages=dpkg-dev binutils-multiarch build-essential dpkg-cross aptitude source=http://ftp.uk.debian.org/debian keyring=debian-archive-keyring suite=unstable omitdebsrc=false Config-Model-2.149/t/model_tests.d/multistrap-examples/igep0020/usr/share/multistrap/arm.conf0000644000175000017500000000042214170053137030457 0ustar domidomi[General] include=/usr/share/multistrap/crosschroot.conf omitrequired=false configscript=config.sh setupscript=setup.sh [Toolchains] packages=g++-4.2-arm-linux-gnu linux-libc-dev-arm-cross source=http://www.emdebian.org/debian keyring=emdebian-archive-keyring suite=stable Config-Model-2.149/t/model_tests.d/multistrap-examples/igep0020/usr/share/multistrap/squeeze.conf0000644000175000017500000000140314170053137031361 0ustar domidomi# Example multistrap configuration file for the squeeze shortcut. [General] arch= directory= # same as --tidy-up option if set to true cleanup=true # same as --no-auth option if set to true # keyring packages listed in each debootstrap will # still be installed. noauth=false # whether to add the /suite to be explicit about where apt # needs to look for packages. Default is false. explicitsuite=false # extract all downloaded archives (default is true) unpack=true # the order of sections is not important. # the debootstrap option determines which repository # is used to calculate the list of Priority: required packages. debootstrap=Debian aptsources=Debian [Debian] packages=apt source=http://ftp.uk.debian.org/debian keyring=debian-archive-keyring suite=squeeze Config-Model-2.149/t/model_tests.d/multistrap-examples/igep0020/home/0000755000175000017500000000000014170053137023644 5ustar domidomiConfig-Model-2.149/t/model_tests.d/multistrap-examples/igep0020/home/foo/0000755000175000017500000000000014170053137024427 5ustar domidomiConfig-Model-2.149/t/model_tests.d/multistrap-examples/igep0020/home/foo/strap-igep0020.conf0000644000175000017500000000063314170053137027655 0ustar domidomi[General] include=/usr/share/multistrap/squeeze.conf arch=armel directory=/mnt/video/domi/donitech/emdebian/igep-nfs-squeeze debootstrap=Grip Debian aptsources=Grip Debian [Grip] packages=ntpdate udev lrzsz netcat net-tools ifupdown openssh-server aptitude source=http://www.emdebian.org/grip keyring=emdebian-archive-keyring suite=squeeze components=main dev [Debian] source=http://ftp.fr.debian.org/debian Config-Model-2.149/t/model_tests.d/multi-ini-examples/0000755000175000017500000000000014170053137021171 5ustar domidomiConfig-Model-2.149/t/model_tests.d/multi-ini-examples/max-overflow/0000755000175000017500000000000014170053137023617 5ustar domidomiConfig-Model-2.149/t/model_tests.d/multi-ini-examples/max-overflow/etc/0000755000175000017500000000000014170053137024372 5ustar domidomiConfig-Model-2.149/t/model_tests.d/multi-ini-examples/max-overflow/etc/bar.conf0000644000175000017500000000002014170053137025775 0ustar domidomiint_with_max=100Config-Model-2.149/t/model_tests.d/backend-cds-examples/0000755000175000017500000000000014170053137021420 5ustar domidomiConfig-Model-2.149/t/model_tests.d/backend-cds-examples/basic0000644000175000017500000000015214170053137022422 0ustar domidomirecord:localhost ipaddr=127.0.0.1 alias=localhost - record:bilbo ipaddr=192.168.0.1 - record:yada Config-Model-2.149/t/model_tests.d/backend-key-value-test-conf.pl0000644000175000017500000000221714170053137023174 0ustar domidomi# # This file is part of Config-Model # # This software is Copyright (c) 2005-2022 by Dominique Dumont. # # This is free software, licensed under: # # The GNU Lesser General Public License, Version 2.1, February 1999 # # test inifile backend use strict; use warnings; # create minimal model to test ini file backend. my @config_classes = ({ name => 'IniKeyValue', element => [ [qw/package-status report-with/] => { qw/type leaf value_type uniline/, }, ], rw_config => { backend => 'IniFile', # specify where is the config file. this must match # the $conf_file_name and $conf_dir variable above assign_char => ':', assign_with => ' : ', config_dir => '/etc/', file => 'test.kv', }, }); # the test suite my @tests = ( { # test complex parameters name => 'bts-control', }, ); return { # specify where is the example file conf_file_name => 'test.kv', conf_dir => '/etc', # specify the name of the class to test model_to_test => "IniKeyValue", config_classes => \@config_classes, tests => \@tests }; Config-Model-2.149/t/model_tests.d/backend-ini-examples/0000755000175000017500000000000014170053137021426 5ustar domidomiConfig-Model-2.149/t/model_tests.d/backend-ini-examples/complex0000644000175000017500000000024214170053137023016 0ustar domidomifoo = foo2 # foo2 comment baz = /bin/sh -c '[ "$(cat /etc/X11/default-display-manager 2>/dev/null)" = "/usr/bin/sddm" ]'' [class1] lista=lista1 #lista1 comment Config-Model-2.149/t/model_tests.d/popcon-examples/0000755000175000017500000000000014170053137020560 5ustar domidomiConfig-Model-2.149/t/model_tests.d/popcon-examples/t00000644000175000017500000000041714170053137021030 0ustar domidomi# 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" Config-Model-2.149/t/model_tests.d/backend-perl-test-conf.pl0000644000175000017500000000247014170053137022235 0ustar domidomi# # This file is part of Config-Model # # This software is Copyright (c) 2005-2022 by Dominique Dumont. # # This is free software, licensed under: # # The GNU Lesser General Public License, Version 2.1, February 1999 # use Config::Model::BackendMgr; use strict; use warnings; my @config_classes = ({ name => 'Host', element => [ [qw/ipaddr alias/] => { type => 'leaf', value_type => 'uniline', }, dummy => {qw/type leaf value_type uniline/}, ] }); push @config_classes, { name => 'Hosts', rw_config => { backend => 'perl_file', config_dir => '/etc/', file => 'hosts.pl', }, element => [ record => { type => 'hash', index_type => 'string', write_empty_value => 1, cargo => { type => 'node', config_class_name => 'Host', }, }, ] }; my @tests = ( { name => 'basic', check => [ 'record:localhost ipaddr' => '127.0.0.1', 'record:bilbo ipaddr' => '192.168.0.1' ] }, ); return { model_to_test => "Hosts", conf_dir => '/etc', conf_file_name => 'hosts.pl', config_classes => \@config_classes, tests => \@tests }; Config-Model-2.149/t/model_tests.d/backend-key-value-examples/0000755000175000017500000000000014170053137022551 5ustar domidomiConfig-Model-2.149/t/model_tests.d/backend-key-value-examples/bts-control0000644000175000017500000000011314170053137024735 0ustar domidomipackage-status: udev dracut initramfs-tools report-with: libreoffice-core Config-Model-2.149/t/model_tests.d/backend-json-examples/0000755000175000017500000000000014170053137021620 5ustar domidomiConfig-Model-2.149/t/model_tests.d/backend-json-examples/basic0000644000175000017500000000025214170053137022623 0ustar domidomi{ "record": [ { "ipaddr": "127.0.0.1", "canonical": "localhost", "alias": "localhost" }, { "ipaddr": "192.168.0.1", "canonical": "bilbo" } ] } Config-Model-2.149/t/model_tests.d/backend-perl-examples/0000755000175000017500000000000014170053137021611 5ustar domidomiConfig-Model-2.149/t/model_tests.d/backend-perl-examples/basic0000644000175000017500000000035314170053137022616 0ustar domidomi my $v = { record => { 'localhost' => { ipaddr => '127.0.0.1', alias => 'localhost', }, bilbo => { ipaddr => '192.168.0.1', }, yada => {} } } ; $v; Config-Model-2.149/t/model_tests.d/popcon-test-conf.pl0000644000175000017500000000066714170053137021212 0ustar domidomi# # This file is part of Config-Model # # This software is Copyright (c) 2005-2022 by Dominique Dumont. # # This is free software, licensed under: # # The GNU Lesser General Public License, Version 2.1, February 1999 # use strict; use warnings; return { conf_file_name => "popularity-contest.conf" , conf_dir => "etc" , model_to_test => "PopCon" , tests => [ { # t0 check => { } }, ], }; Config-Model-2.149/t/model_tests.d/backend-plainfile-examples/0000755000175000017500000000000014170053137022612 5ustar domidomiConfig-Model-2.149/t/model_tests.d/backend-plainfile-examples/with-index/0000755000175000017500000000000014170053137024672 5ustar domidomiConfig-Model-2.149/t/model_tests.d/backend-plainfile-examples/with-index/debian/0000755000175000017500000000000014170053137026114 5ustar domidomiConfig-Model-2.149/t/model_tests.d/backend-plainfile-examples/with-index/debian/bar.move.list0000644000175000017500000000003314170053137030516 0ustar domidomibar val1 bar val2 bar val3 Config-Model-2.149/t/model_tests.d/backend-plainfile-examples/with-index/debian/foo.install.list0000644000175000017500000000002214170053137031233 0ustar domidomifoo val1 foo val2 Config-Model-2.149/t/model_tests.d/backend-plainfile-examples/with-index/debian/bar.install.list0000644000175000017500000000003314170053137031216 0ustar domidomibar val1 bar val2 bar val3 Config-Model-2.149/t/model_tests.d/backend-cds-test-conf.pl0000644000175000017500000000246714170053137022052 0ustar domidomi# # This file is part of Config-Model # # This software is Copyright (c) 2005-2022 by Dominique Dumont. # # This is free software, licensed under: # # The GNU Lesser General Public License, Version 2.1, February 1999 # use Config::Model::BackendMgr; use strict; use warnings; my @config_classes = ([ name => 'Host', element => [ [qw/ipaddr alias/] => { type => 'leaf', value_type => 'uniline', }, dummy => {qw/type leaf value_type uniline/}, ] ]); push @config_classes, [ name => 'Hosts', rw_config => { backend => 'cds_file', config_dir => '/etc/', file => 'hosts.cds', }, element => [ record => { type => 'hash', index_type => 'string', write_empty_value => 1, cargo => { type => 'node', config_class_name => 'Host', }, }, ] ]; my @tests = ( { name => 'basic', check => [ 'record:localhost ipaddr' => '127.0.0.1', 'record:bilbo ipaddr' => '192.168.0.1' ] }, ); return { tests => \@tests, model_to_test => "Hosts", config_classes => \@config_classes, conf_dir => '/etc', conf_file_name => 'hosts.cds' }; Config-Model-2.149/t/auto_load_model.t0000644000175000017500000000207214170053137016217 0ustar domidomi# -*- cperl -*- use ExtUtils::testlib; use Test::More; use Test::Memory::Cycle; use Config::Model; use Config::Model::Tester::Setup qw/init_test/; use warnings; use strict; use lib "t/lib"; my ($model, $trace) = init_test(); my $inst = $model->instance( root_class_name => 'Master', 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', instance_name => 'test1' ); ok( $inst2, "created dummy instance 2" ); memory_cycle_ok($model, "memory cycles"); done_testing; Config-Model-2.149/t/report.t0000644000175000017500000000437714170053137014415 0ustar domidomi# -*- cperl -*- use ExtUtils::testlib; use Test::More; use Test::Memory::Cycle; use Config::Model; use Config::Model::Tester::Setup qw/init_test/; use warnings; use strict; use lib "t/lib"; my ($model, $trace) = init_test(); my $inst = $model->instance( root_class_name => 'Master', 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, "memory cycle"); done_testing; Config-Model-2.149/t/gen-class-doc.t0000644000175000017500000000247614170053137015517 0ustar domidomiuse ExtUtils::testlib; use Test::More; use Test::Memory::Cycle; use Config::Model; use Config::Model::Tester::Setup qw/init_test/; use Pod::Simple; use warnings; use 5.10.1; use strict; use lib "t/lib"; my ($model, $trace) = init_test(); $model->load( 'Master', 'Config/Model/models/Master.pl' ); ok( 1, "big_model loaded" ); $model->augment_config_class( name => "Master", element => [ 'big_string' => { type => 'leaf', value_type => 'string', default => "A very\nlong\n\n\ndefault\nvalue\n" } ] ); 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" ); foreach my $class (sort keys %$res) { my $pod = $res->{$class}; my $parser = Pod::Simple->new(); $parser->no_errata_section( 1 ); $parser->complain_stderr(1); $parser->parse_string_document($pod); my $res = $parser->any_errata_seen(); say "Bad pod:\n++++++++++++\n$pod\n+++++++++++++" if $res; is($res, 0, "check generated pod error for class $class"); } memory_cycle_ok($model, "memory cycles"); done_testing(); Config-Model-2.149/t/node.t0000644000175000017500000001314014170053137014013 0ustar domidomi# -*- cperl -*- use ExtUtils::testlib; use Test::More ; use Test::Exception; use Test::Memory::Cycle; use Config::Model; use Config::Model::Tester::Setup qw/init_test/; use Test::Log::Log4perl; use strict; use warnings; my ($model, $trace) = init_test(); $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', gist => '{X} and {Y}', 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', gist => '{bar X} and {bar Y}', element => [ bar => { type => 'node', config_class_name => 'Sarge' } ] ); $model->create_config_class( name => "Master", level => [ qw/captain/ => 'important' ], gist => '{captain bar X} and {captain bar Y}', 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" ); Test::Log::Log4perl-> ignore_priority('INFO'); 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" ); 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" ); subtest "check deprecated element warning" => sub{ my $xp = Test::Log::Log4perl->expect([ 'User', warn => qr/Element 'D' of node 'captain bar' is deprecated/ ]); $b->fetch_element('D'); }; $b->fetch_element('X')->store('Av'); $b->fetch_element('Y')->store('Bv'); my $expected_gist = 'Av and Bv'; is($b->fetch_gist,$expected_gist, 'test Sarge gist'); is($w->fetch_gist,$expected_gist, 'test Captain gist'); is($root->fetch_gist,$expected_gist, 'test Master gist'); 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" ); my @prev_next_tests = ( [ undef, 'captain' ], [ '', 'captain' ], [qw/captain array_args/], [qw/array_args hash_args/] ); foreach (@prev_next_tests) { 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 '' ); }; memory_cycle_ok($model, "memory cycle"); done_testing ; Config-Model-2.149/t/load-model.t0000644000175000017500000000151014170053137015101 0ustar domidomiuse Test::More; use Test::Memory::Cycle; use Test::Differences; use Path::Tiny; use Config::Model::Tester::Setup qw/init_test setup_test_dir/; use strict; use warnings; use 5.20.0; use feature qw/postderef/; no warnings qw/experimental::postderef/; use lib 'wr_root/load_model_snippets'; my ($model, $trace) = init_test(); # pseudo root where config files are written by config-model my $wr_root = setup_test_dir(); my $file = path('t/lib/test_ini_backend_model.pl'); # any model is fine ## no critic (BuiltinFunctions::ProhibitStringyEval) my $data = eval($file->slurp_utf8); my @expected = map { $_->{name} } $data->@*; # load model like Config::Model::Itself my @models = $model -> load ( 'Tmp' , $file->absolute ) ; is_deeply(\@models, \@expected,"check loaded classes"); memory_cycle_ok($model,"memory cycles"); done_testing; Config-Model-2.149/t/pod.t0000644000175000017500000000041014170053137013644 0ustar domidomiuse strict; use warnings; BEGIN { 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; use Test::Pod 1.00; all_pod_files_ok( ); Config-Model-2.149/t/pod_generation.t0000644000175000017500000000137714170053137016074 0ustar domidomi# -*- cperl -*- use ExtUtils::testlib; use Test::More; use Test::Memory::Cycle; use Config::Model; use Config::Model::Tester::Setup qw/init_test setup_test_dir/; use Test::Exception; use warnings; use strict; use lib "t/lib"; my ($model, $trace) = init_test(); # pseudo root where config files are written by config-model my $wr_root = setup_test_dir(); throws_ok { $model->generate_doc('Blork'); } qr/Unknown configuration class/, "test generate_doc error handling"; $model->generate_doc('Master') if $trace; $model->generate_doc( 'Master', $wr_root ); for (qw /Master.pod SlaveY.pod SlaveZ.pod SubSlave2.pod SubSlave.pod/) { ok( -r "$wr_root/Config/Model/models/$_", "Found doc $_" ); } memory_cycle_ok($model, "memory cycle"); done_testing; Config-Model-2.149/t/describe_node.t0000644000175000017500000002327014170053137015660 0ustar domidomi# -*- cperl -*- use ExtUtils::testlib; use Test::More; use Test::Memory::Cycle; use Test::Log::Log4perl; use Config::Model; use Config::Model::Tester::Setup qw/init_test/; use warnings; use strict; use lib "t/lib"; use utf8; use open qw(:std :utf8); # undeclared streams in UTF-8 Test::Log::Log4perl->ignore_priority("info"); my ($model, $trace) = init_test(); $model->load(Master => 'Config/Model/models/Master.pl'); ok( 1, "loaded big_model" ); $model->augment_config_class( name => 'Master', element => [ "list_with_warn_duplicates" => { type => 'list', duplicates => 'warn', cargo => { type => 'leaf', value_type => 'string'} } ], ); ok( 1, "augmented big_model" ); my $inst = $model->instance( root_class_name => 'Master', instance_name => 'test1' ); ok( $inst, "created dummy instance" ); my $root = $inst->config_root; ok( $root, "Config root created" ); $inst->layered_start; # to be visible with mode => user $root->load('a_string="toto tata"'); $inst->layered_stop; subtest "load and check for duplicate values" => sub { my $step = 'std_id:ab X=Bv - std_id:bc X=Av - ' . 'hash_a:toto=toto_value hash_a:titi=titi_value ' . 'lista=a,b,c,d olist:0 X=Av - olist:1 X=Bv - ' . 'list_with_warn_duplicates=foo,bar,foo ' . 'my_check_list=toto my_reference="titi" yes_no_boolean=1'; ok( $root->load( step => $step ), "set up data in tree with '$step'" ); { my $xp = Test::Log::Log4perl->expect( ignore_priority => "info", ['User', warn => qr/Duplicated value/] ); # so # TODO: hat list_with_warn_duplicates comes with '/!\' $root->deep_check; } }; subtest "Check root description" => sub { my $description = $root->describe; $description =~ s/\s*\n/\n/g; print "description string:\n$description" if $trace; my $expect = <<'EOF' ; name │ type │ value ────────────────────────────┼────────────┼───────────── std_id │ node hash │ lista │ list │ a,b,c,d listb │ list │ hash_a:titi │ string │ titi_value hash_a:toto │ string │ toto_value hash_b │ value hash │ [empty hash] ordered_hash │ value hash │ [empty hash] olist │ │ node list tree_macro │ enum │ [undef] warp │ node │ slave_y │ node │ string_with_def │ string │ "yada yada" a_uniline │ uniline │ "yada yada" a_string │ string │ "toto tata" int_v │ integer │ 10 my_check_list │ check_list │ toto a_boolean │ boolean │ [undef] yes_no_boolean │ boolean │ yes my_reference │ reference │ titi list_with_warn_duplicates ⚠ │ list │ foo,bar,foo EOF is( $description, $expect, "check root description " ); }; subtest "Check root verbose description with hide empty" => sub { my $description = $root->describe(hide_empty => 1, verbose => 1); $description =~ s/\s*\n/\n/g; print "description string:\n$description" if $trace; my $expect = <<'EOF' ; name │ type │ value │ comment ────────────────────────────┼────────────┼─────────────┼───────────────────── std_id │ node hash │ │ keys: "ab" "bc" lista │ list │ a,b,c,d │ hash_a:titi │ string │ titi_value │ hash_a:toto │ string │ toto_value │ olist │ │ node list │ indexes: 0 1 warp │ node │ │ slave_y │ node │ │ string_with_def │ string │ "yada yada" │ default: "yada yada" a_uniline │ uniline │ "yada yada" │ default: "yada yada" a_string │ string │ "toto tata" │ default: "toto tata", mandatory int_v │ integer │ 10 │ default: 10 my_check_list │ check_list │ toto │ yes_no_boolean │ boolean │ yes │ default: yes my_reference │ reference │ titi │ list_with_warn_duplicates ⚠ │ list │ foo,bar,foo │ EOF is( $description, $expect, "check root description without empty values" ); }; subtest "Check root description with hide empty" => sub { my $description = $root->describe(hide_empty => 1); $description =~ s/\s*\n/\n/g; print "description string:\n$description" if $trace; my $expect = <<'EOF' ; name │ type │ value ────────────────────────────┼────────────┼──────────── std_id │ node hash │ lista │ list │ a,b,c,d hash_a:titi │ string │ titi_value hash_a:toto │ string │ toto_value olist │ │ node list warp │ node │ slave_y │ node │ string_with_def │ string │ "yada yada" a_uniline │ uniline │ "yada yada" a_string │ string │ "toto tata" int_v │ integer │ 10 my_check_list │ check_list │ toto yes_no_boolean │ boolean │ yes my_reference │ reference │ titi list_with_warn_duplicates ⚠ │ list │ foo,bar,foo EOF is( $description, $expect, "check root description without empty values and non verbose" ); }; subtest "Check std_id:ab verbose description" => sub { my$description = $root->grab('std_id:ab')->describe(verbose => 1); $description =~ s/\s*\n/\n/g; print "description string:\n$description" if $trace; my $expect = <<'EOF' ; name │ type │ value │ comment ─────┼──────┼─────────┼───────────────────── Z │ enum │ [undef] │ choice: Av Bv Cv X │ enum │ Bv │ choice: Av Bv Cv DX │ enum │ Dv │ default: Dv, choice: Av Bv Cv Dv EOF is( $description, $expect, "check std_id:ab description " ); }; subtest "Check std_id:ab verbose description" => sub { my $description = $root->grab('std_id:ab')->describe(verbose => 1, hide_empty => 1); $description =~ s/\s*\n/\n/g; print "description string:\n$description" if $trace; my $expect = <<'EOF' ; name │ type │ value │ comment ─────┼──────┼───────┼───────────────────── X │ enum │ Bv │ choice: Av Bv Cv DX │ enum │ Dv │ default: Dv, choice: Av Bv Cv Dv EOF is( $description, $expect, "check std_id:ab description without empty values" ); }; subtest "Check root description of std_id" => sub { my $expect = <<'EOF' ; name │ type │ value │ comment ───────┼───────────┼──────────┼───────────────────── std_id │ node hash │ │ keys: "ab" "bc" EOF my $description = $root->describe(verbose => 1, 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" ); }; subtest "Check root verbose description with a pattern" => sub { my $expect = <<'EOF' ; name │ type │ value │ comment ────────────┼────────────┼──────────────┼───────────────────── hash_a:titi │ string │ titi_value │ hash_a:toto │ string │ toto_value │ hash_b │ value hash │ [empty hash] │ EOF my $description = $root->describe(verbose => 1, 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" ); }; subtest "Check std_id:ab verbose description" => sub { $root->fetch_element('a_string')->store(<describe(verbose => 1, pattern => qr/^a_string/ ); $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, "check memory cycles"); done_testing; Config-Model-2.149/t/warped_node.t0000644000175000017500000002067414170053137015367 0ustar domidomi# -*- cperl -*- use ExtUtils::testlib; use Test::More; use Test::Differences; use Test::Memory::Cycle; use Config::Model; use Config::Model::Tester::Setup qw/init_test/; use strict; use warnings ; my ($model, $trace) = init_test(); $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', morph => 1, warp => { follow => '! tree_macro', rules => { XY => { config_class_name => 'SlaveY', }, mXY => { config_class_name => 'SlaveY', }, XZ => { config_class_name => 'SlaveZ' } } } }, }, 'a_warped_node' => { type => 'warped_node', morph => 1, warp => { follow => '! tree_macro', rules => { XY => { config_class_name => ['SlaveY'] }, mXY => { config_class_name => 'SlaveY' }, XZ => { config_class_name => 'SlaveZ' } } } }, 'a_hidden_node' => { type => 'warped_node', config_class_name => 'SlaveZ', level => 'hidden', warp => { follow => '! tree_macro', rules => { XZ => { level => 'normal' } } } }, bool_object => { type => 'warped_node', warp => { 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" ); $inst->initial_load_stop; my $root = $inst->config_root; my $tm = $root->fetch_element('tree_macro'); $tm->store('AR'); $inst->clear_changes; 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' ); eq_or_diff([$inst->list_changes], ["tree_macro: 'AR' -> 'XY'"], "check change message after setting tree_macro to XY"); print join( "\n", $inst->list_changes("\n") ), "\n" if $trace; $inst->clear_changes; is( $root->fetch_element('tree_macro')->store('XZ'), 1, 'set master->tree_macro to XZ' ); is( $root->fetch_element('a_hidden_node')->is_accessible, 1, 'check that a_hidden_node is accessible' ); eq_or_diff([$inst->list_changes], ["tree_macro: 'XY' -> 'XZ'"], "check change message after setting tree_macro to XY"); print join( "\n", $inst->list_changes("\n") ), "\n" if $trace; $inst->clear_changes; $root->fetch_element('tree_macro')->store('XY'); 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' ); for (qw/X Z/) { is( $ahown->fetch_with_id(234)->fetch_element($_)->fetch, 'Av', "reading master a_hash_of_warped_nodes:234 $_ (default value)" ); } for (qw/X Z/) { is( $ahown->fetch_with_id(234)->fetch_element($_)->store('Cv'), 1, "Set master a_hash_of_warped_nodes:234 $_ to Cv" ); } 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; Config-Model-2.149/t/hash_id_of_values.t0000644000175000017500000004243514170053137016541 0ustar domidomi# -*- cperl -*- use ExtUtils::testlib; use Test::More ; use Test::Memory::Cycle; use Config::Model; use Config::Model::Tester::Setup qw/init_test/; use Test::Exception; use Test::Differences; use Test::Log::Log4perl; use strict; use warnings; my ($model, $trace) = init_test(); # 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 $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', write_empty_value => 1, # 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" ); Test::Log::Log4perl-> ignore_priority('INFO'); 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, 1, "verify instance needs_save status after element creation" ); is( $b1->store('foo'), 1, "Storing in id 1" ); is( $inst->needs_save, 2, "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, 4, "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, 4, "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->delete(2), undef, "delete id 2 again even if already deleted" ); is( $inst->needs_save, 0, "verify instance needs_save status after duplicate delete -> no need to save again" ); 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; subtest "summary method" => sub { my $s = $root->fetch_element('plain_hash')->fetch_with_id(3); $s->store("Lorem ipsum\ndolor sit amet, consectetur adipiscing elit,"); is($s->fetch_summary, "Lorem ipsum dol...", "test summary on string"); $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)" ); $oh->sort; eq_or_diff( [ $oh->fetch_all_indexes ], [qw/a d e x z/], "check index order of ordered_hash after sort" ); $oh->insort('v')->store('v val'); eq_or_diff( [ $oh->fetch_all_indexes ], [qw/a d e v x z/], "check index order of ordered_hash after insort" ); is($oh->fetch_with_id('v')->fetch,'v val',"check value entered with insort"); $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" ); subtest "check ordered load warnings" => sub { $oh->clear; my $foo = Test::Log::Log4perl->expect( ignore_priority => "info", ['Tree.Element.Id.Hash', warn => qr/Element order is not defined/ ] ); # this one does not trigger a warning $oh->load_data({__skip_order => 1, qw/a va c vc b vb/}); eq_or_diff( [ $oh->fetch_all_indexes ], [qw/a b c/], "check index order of ordered_hash loaded with hash and __skip_order" ); # this one does $oh->load_data({ qw/e ve d vd/ }); eq_or_diff( [ $oh->fetch_all_indexes ], [qw/a b c d e/], "check index order of ordered_hash loaded with hash and no __skip_order" ); } ; subtest "check ordered load mismatch" => sub { throws_ok { $oh->load_data( { __order => [qw/a b c d e/], qw/a va b vb c vc/ } ); } 'Config::Model::Exception::LoadData', "check not matching key"; }; $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" ); { my $foo = Test::Log::Log4perl->expect([ 'User', warn => qr/key 'foo2' should not match/, warn => qr/key 'foo2 multi\[\.\.\.\]' should not match/, warn => qr/key 'bar2' should match foo/, ]); # test warnings with keys my $hwwikm = $root->fetch_element('hash_with_warn_if_key_match'); $hwwikm->fetch_with_id('foo2'); $hwwikm->fetch_with_id("foo2 multi\nline\nid"); my $hwwukm = $root->fetch_element('hash_with_warn_unless_key_match'); $hwwukm->fetch_with_id('bar2'); } # 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 my $idx ( $hwdai->fetch_all_indexes ) { is( $hwdai->fetch_with_id($idx)->fetch, "$idx stuff", "check default_with_init with '$idx'" ); } # 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; Config-Model-2.149/t/perl-critic.t0000644000175000017500000000102214170053137015277 0ustar domidomi use strict; use warnings; use File::Spec; use Test::More; use English qw(-no_match_vars); if ( not $ENV{TEST_AUTHOR} ) { my $msg = 'Author test. Set $ENV{TEST_AUTHOR} to a true value to run.'; plan( skip_all => $msg ); } eval { require Test::Perl::Critic; }; if ( $EVAL_ERROR ) { my $msg = 'Test::Perl::Critic required to criticise code'; plan( skip_all => $msg ); } my $rcfile = File::Spec->catfile( 't', 'perlcriticrc' ); Test::Perl::Critic->import( -profile => $rcfile ); all_critic_ok(); Config-Model-2.149/t/value.t0000644000175000017500000010755614170053137014221 0ustar domidomi# -*- cperl -*- use ExtUtils::testlib; use Test::More; use Test::Exception; use Test::Differences; use Test::Memory::Cycle; use Config::Model; use Config::Model::Tester::Setup qw/init_test/; use Config::Model::Value; use Test::Log::Log4perl; use strict; use warnings; use 5.010; Test::Log::Log4perl->ignore_priority("info"); binmode STDOUT, ':encoding(UTF-8)'; my ($model, $trace) = init_test(); # minimal set up to get things working $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', }, string_with_help => { type => 'leaf', class => 'Config::Model::Value', value_type => 'string', help => { 'foob[ao]b' => 'help for foobob* or foobab* things', 'foo' => 'help for foo things', '.' => 'help for non foo things' } }, 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_plain => { type => 'leaf', value_type => 'boolean', }, 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_if_match_slashed => { type => 'leaf', value_type => 'string', warn_if_match => { 'oo/b' => { fix => 's!oo/b!!;' } }, }, 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;' } }, }, integer_with_warn_if => { type => 'leaf', value_type => 'integer', warn_if => { warn_test => { code => 'defined $_ && $_ < 9;', msg => 'should be greater than 9', fix => '$_ = 10;' } }, }, warn_unless => { type => 'leaf', value_type => 'string', warn_unless => { warn_test => { code => 'defined $_ and /\w/', msg => 'should not be empty', fix => '$_ = "foobar";' } }, }, warn_unless_file => { type => 'leaf', value_type => 'string', warn_unless => { warn_test => { code => 'file($_)->exists', msg => 'file $_ should exist', fix => '$_ = "value.t";' } }, }, 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; 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', # root_dir is used to test warn_unless_file root_dir => 't', 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; subtest "simple scalar" => sub { 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" ); is( $i->has_data, 0, "check has_data on empty scalar" ); $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->has_data, 1, "check has_data 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" ); ok($i->check_value(), "call check_value without argument"); }; subtest "error handling on simple scalar" => sub { my $i = $root->fetch_element('scalar'); 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; ok( ! $i->store(value => 5, check => 'skip'), "bad value was skipped"); is($i->fetch,1,"check original value"); is($i->store(value => 5, check => 'no'),1 ,"bad value was force fed"); is($i->fetch(check => 'no'),5,"check stored bad value"); throws_ok { $i->fetch() } 'Config::Model::Exception::WrongValue', "check that reading a bad value trigges an error"; is($i->fetch(check => 'skip'),undef,"check bad read value can be skipped"); is($i->fetch(check => 'no'),5,"check stored bad value has not changed"); $i->store(1); # fix the error condition }; subtest "summary method" => sub { my $i = $root->fetch_element('scalar'); $i->store(4); is($i->fetch_summary, 4, "test summary on integer"); my $s = $root->fetch_element('string'); $s->store("Lorem ipsum dolor sit amet, consectetur adipiscing elit,"); is($s->fetch_summary, "Lorem ipsum dol...", "test summary on string"); $s->store("Lorem ipsum\ndolor sit amet, consectetur adipiscing elit,"); is($s->fetch_summary, "Lorem ipsum dol...", "test summary on string with \n"); }; subtest "bounded number" => sub { 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" ); }; subtest "mandatory string" => sub { 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; }; subtest "mandatory string provided with a default value" => sub { my $mwdv = $root->fetch_element('mandatory_with_default_value'); # note: calling fetch before store triggers a "notify_change" to # let user know that his file was changed by model $mwdv->store('booya'); # emulate reading a file containing default value is( $mwdv->has_data, 0, "check has_data after storing 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; }; subtest "mandatory boolean" => sub { 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/is not boolean/ ); check_store_error( $mb, 2, qr/is not boolean/ ); }; subtest "boolean where values are translated" => sub { $inst->clear_changes; my %data = ( 0 => 0, 1 => 1, off => 0, on => 1, no => 0, yes => 1, No => 0, Yes => 1, NO => 0, YES => 1, true => 1, false => 0, True => 1, False => 0, '' => 0); my $bp = $root->fetch_element('boolean_plain'); while (my ($v,$expect) = each %data) { $bp->store($v); is( $bp->fetch, $expect, "boolean_plain: '$v'->'$expect'" ); } }; subtest "check changes with boolean where values are translated to true/false" => sub { $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'" ); my @changes = "boolean_with_write_as has new value: 'false'"; eq_or_diff([$inst->list_changes],\@changes, "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'" ); push @changes, "boolean_with_write_as: 'false' -> 'true'"; eq_or_diff([$inst->list_changes], \@changes, "check change message after writing 'boolean_with_write_as'"); my $bwwaad = $root->fetch_element('boolean_with_write_as_and_default'); is( $bwwa->fetch, 'true', "boolean_with_write_as_and_default reads true" ); }; subtest "boolean_with_write_as_and_default" => sub { my $bwwaad = $root->fetch_element('boolean_with_write_as_and_default'); is( $bwwaad->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; }; subtest "enum" => sub { 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" ); }; subtest "uppercase conversion" => sub { 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" ); }; subtest "lowercase conversion" => sub { 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" ); }; subtest "integrated help on enum" => sub { 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" ); }; subtest "integrated help on string" => sub { my $value_with_help = $root->fetch_element('string_with_help'); my $foo_help = 'help for foo things'; my $foob_help = 'help for foobob* or foobab* things'; my $other_help = 'help for non foo things'; my %test = ( fooboba => $foob_help, foobaba => $foob_help, foobbba => $foo_help, foo => $foo_help, foobar => $foo_help, f => $other_help, afoo => $other_help, ); foreach my $k (sort keys %test) { is( $value_with_help->get_help($k), $test{$k} , "test string help on $k" ); } }; subtest "upstream default value" => sub { 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" ); is( $up_def->has_data, 0, "does not have data"); $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" ); is( $up_def->has_data, 1, "has data"); }; subtest "uniline type" => sub { 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" ); }; subtest "replace feature" => sub { 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" ); }; subtest "preset feature" => sub { 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" ); }; subtest "layered feature" => sub { 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" ); is( $l_scalar->has_data, 0, "scalar: has no data" ); is( $l_scalar->fetch(mode => 'non_upstream_default'), 3, "scalar: read non upstream default value before store" ); # store a value identical to the layered value $l_scalar->store(3); is( $l_scalar->fetch, 3, "scalar: read value as backend value after store" ); is( $l_scalar->has_data, 0, "scalar: has no data after store layered 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(mode => 'non_upstream_default'), 4, "scalar: read non upstream default value after store" ); is( $l_scalar->fetch_custom, 4, "scalar: read custom_value" ); is( $l_scalar->has_data, 1, "scalar: has data" ); 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" ); is( $l_enum->has_data, 0, "enum: has no data" ); $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( $l_enum->has_data, 1, "enum: has data" ); 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"); }; subtest "match regexp" => sub { 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" ); }; subtest "validation done with a Parse::RecDescent grammar" => sub { 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" ); } }; subtest "warn_if_match with a string" => sub { my $wim = $root->fetch_element('warn_if_match'); { my $xp = Test::Log::Log4perl->expect( ignore_priority => "info", ['User', warn => qr/should not match/] ); $wim->store('foobar'); } is( $wim->has_fixes, 1, "test has_fixes" ); { # check code is not run when check is 'no'. my $xp = Test::Log::Log4perl->expect(ignore_priority => "debug", []); $wim->fetch( check => 'no'); } is( $wim->fetch( check => 'no', silent => 1 ), 'foobar', "check warn_if stored value" ); is( $wim->has_fixes, 1, "test has_fixes after fetch with check=no" ); is( $wim->fetch( mode => 'standard' ), undef, "check warn_if standard value" ); is( $wim->has_fixes, 1, "test has_fixes after fetch with mode = standard" ); ### test fix included in model $wim->apply_fixes; is( $wim->fetch, 'FOOBAR', "test if fixes were applied" ); }; subtest "warn_if_match with a slash in regexp" => sub { my $wim = $root->fetch_element('warn_if_match_slashed'); { my $xp = Test::Log::Log4perl->expect( ignore_priority => "info", ['User', warn => qr/should not match/] ); $wim->store('foo/bar'); } is( $wim->has_fixes, 1, "test has_fixes" ); { # check code is not run when check is 'no'. my $xp = Test::Log::Log4perl->expect(ignore_priority => "debug", []); $wim->fetch( check => 'no'); } is( $wim->fetch( check => 'no', silent => 1 ), 'foo/bar', "check warn_if stored value" ); is( $wim->has_fixes, 1, "test has_fixes after fetch with check=no" ); ### test fix included in model $wim->apply_fixes; is( $wim->fetch, 'far', "test if fixes were applied" ); }; subtest "warn_if_number with a regexp" => sub { my $win = $root->fetch_element('warn_if_number'); { my $xp = Test::Log::Log4perl->expect( ignore_priority => 'info', ['User', warn => qr/should not have numbers/] ); $win->store('bar51'); } is( $win->has_fixes, 1, "test has_fixes" ); $win->apply_fixes; is( $win->fetch, 'bar', "test if fixes were applied" ); }; subtest "integer_with_warn_if" => sub { my $iwwi = $root->fetch_element('integer_with_warn_if'); { my $xp = Test::Log::Log4perl->expect( ignore_priority => 'info', ['User', warn => qr/should be greater than 9/] ); $iwwi->store('5'); } is( $iwwi->has_fixes, 1, "test has_fixes" ); $iwwi->apply_fixes; is( $iwwi->fetch, 10, "test if fixes were applied" ); }; my $warn_unless_test = sub { my $wup = $root->fetch_element('warn_unless_match'); my $v = shift; { my $xp = Test::Log::Log4perl->expect( ignore_priority => 'info', ['User', warn => qr/should match/] ); $wup->store($v); } is( $wup->has_fixes, 1, "test has_fixes" ); $wup->apply_fixes; is( $wup->fetch, "foo$v", "test if fixes were applied" ); }; subtest "warn_unless_match feature with unline value" => $warn_unless_test, "bar" ; subtest "warn_unless_match feature with multiline value" => $warn_unless_test, "bar\nbaz\bazz\n"; subtest "unconditional feature" => sub { my $aw = $root->fetch_element('always_warn'); my $xp = Test::Log::Log4perl->expect( ignore_priority => 'info', ['User', warn => qr/always/] ); $aw->store('whatever'); }; subtest "warning and repeated storage in same element" => sub { my $aw = $root->fetch_element('always_warn'); my $xp = Test::Log::Log4perl->expect( ignore_priority => 'info', [ 'User', ( warn => qr/always/ ) x 2 ] ); $aw->store('what ?'); # warns $aw->store('what ?'); # does not warn $aw->store('what never'); # warns }; subtest "unicode" => sub { my $wip = $root->fetch_element('warn_if_match'); 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; subtest "replace_follow" => sub { 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; }; subtest "Standards-Version" => sub { my $sv = $root->fetch_element('Standards-Version'); { my $xp = Test::Log::Log4perl->expect( ignore_priority => 'info', ['User', warn => qr/Current/] ); # store old standard version $sv->store('3.9.1'); } 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" ); }; subtest "assert" => sub { 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" ); }; subtest "warn_unless" => sub { my $warn_unless = $root->fetch_element('warn_unless'); my $xp = Test::Log::Log4perl->expect( ignore_priority => 'info', ['User', warn => qr/should not be empty/] ); $warn_unless->fetch(); $warn_unless->apply_fixes; ok( 1, "warn_unless apply_fixes called" ); is( $warn_unless->fetch, 'foobar', "check fixed warn_unless pb" ); }; subtest "warn_unless_file" => sub { my $warn_unless_file = $root->fetch_element('warn_unless_file'); my $xp = Test::Log::Log4perl->expect( ignore_priority => 'info', ['User', warn => qr/file not-value.t should exist/] ); $warn_unless_file->store('not-value.t'); $warn_unless_file->apply_fixes; ok( 1, "warn_unless_file apply_fixes called" ); is( $warn_unless_file->fetch, 'value.t', "check fixed warn_unless_file" ); }; subtest "file and dir value types" => sub { my $t_file = $root->fetch_element('t_file'); my $t_dir = $root->fetch_element('t_dir'); { my $xp = Test::Log::Log4perl->expect( ignore_priority => 'info', [ 'User', warn => qr/not exist/, warn => qr/not a file/, warn => qr/not a dir/, ] ); $t_file->store('toto'); $t_file->store('t'); $t_dir->store('t/value.t'); } $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"); }; subtest "problems during initial load" => sub { 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; Config-Model-2.149/t/recursive_warp_value.t0000644000175000017500000000646214170053137017333 0ustar domidomi# -*- cperl -*- use ExtUtils::testlib; use Test::More; use Test::Memory::Cycle; use Config::Model; use Config::Model::Tester::Setup qw/init_test/; use strict; use warnings; my ($model, $trace) = init_test(); # minimal set up to get things working $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 => { formula => 'macro is $m, my slot is &slot', variables => { '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, "memory cycle"); done_testing; Config-Model-2.149/t/hash_with_data_migration.t0000644000175000017500000000512314170053137020110 0ustar domidomi# -*- cperl -*- 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::Tester::Setup qw/init_test/; use strict; use warnings; my ($model, $trace) = init_test(); # 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" ); done_testing; Config-Model-2.149/t/warped_node_collateral.t0000644000175000017500000000736214170053137017570 0ustar domidomi# -*- cperl -*- use ExtUtils::testlib; use Test::More; use Test::Exception; use Test::Memory::Cycle; use Config::Model; use Config::Model::Tester::Setup qw/init_test/; use strict; use warnings; my ($model, $trace) = init_test(); $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 => { type => 'warped_node', warp => { follow => { fst => '- fs_vfstype' }, 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', warp => { 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, "memory cycle"); done_testing; Config-Model-2.149/t/value_compute.t0000644000175000017500000006132014170053137015741 0ustar domidomi# -*- cperl -*- use Test::More; use Test::Differences; use Test::Memory::Cycle; use Config::Model; use Config::Model::Tester::Setup qw/init_test/; use Test::Log::Log4perl; use strict; use warnings; use 5.10.1; my ($model, $trace, $args) = init_test('rd-hint','rd-trace'); note("use --rd-hint or --rd-trace options to debug Parse::RecDescent"); Test::Log::Log4perl-> ignore_priority('INFO'); $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', }, }, Licenses => { type => 'hash', index_type => 'string', cargo => { type => 'node', config_class_name => 'LicenseSpec' } }, ] ); # 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, }, }, short_name_from_above1 => { 'type' => 'leaf', 'value_type' => 'uniline', compute => { 'formula' => '&element( - - )', }, }, short_name_from_above2 => { 'type' => 'leaf', 'value_type' => 'uniline', compute => { 'formula' => '&element( -- )', }, }, short_name_from_above3 => { 'type' => 'leaf', 'value_type' => 'uniline', compute => { 'formula' => '&element( -2 )', }, }, ] ); $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_warning => { type => 'leaf', class => 'Config::Model::Value', value_type => 'integer', compute => { formula => '$a + $b', variables => { a => '- av', b => '- bv' }, allow_override => 1, }, warn_if => { positive_test => { code => 'defined $_ && $_ < 0;', msg => 'should be positive', fix => '$_ = 0;' } }, 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_warning 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 = Parse::RecDescent->new($Config::Model::ValueComputer::compute_grammar); use warnings 'once'; { no warnings qw/once/; $::RD_HINT = 1 if $args->{'rd-hint'}; $::RD_TRACE = 1 if $args->{'rd-trace'}; } 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" ); my $code = q{&location() =~ /^copyright/ ? $self->grab_value('! control source Source') : '''}; $ref = $parser->pre_compute( $code, 1, $object, $rules, $srules ); $code =~ s/&location\(\)/$object->location/e; is( $$ref, $code, "test pre_compute parser with code" ); $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 => 'no' ), undef, "returns undef when computed integer is invalid and check is no (a: 1, b: -2)" ); is( $compute_int->fetch( check => 'skip' ), 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)" ); is( $cwu->fetch( mode => 'user' ), 3, "test computed with upstream value (standard)" ); $cwu->store(4); is( $cwu->fetch, 4, "test overridden value" ); is( $cwu->fetch( mode => 'user' ), 4, "test computed with upstream value (standard)" ); 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 after 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" ); subtest "check Source2 compute with undef_is" => sub { my $v; my $xp = Test::Log::Log4perl->expect([ 'User', (warn => qr/deprecated/) x 2]); $v = $root->grab_value( step => 'Source2' ); 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( $lic_gpl->grab('text')->fetch_custom, undef, "check computed custom value" ); $lic_gpl->grab('text')->store($lic_gpl->grab_value('text')); is( $lic_gpl->grab('text')->fetch_custom, undef, "check computed custom value after storing same value" ); 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' ); subtest "check warning with computed value and overide" => sub { my $xp = Test::Log::Log4perl->expect([ 'User', warn => qr/should be positive/ ]); my $cww = $root->fetch_element('compute_with_warning'); $av->store(-2); $bv->store(-1); $cww->fetch; is($cww->has_warning, 1, "check has_warning after check"); is($cww->perform_compute, -3); is($cww->has_warning, 1, "check has_warning after compute"); $cww->store(2); is($cww->fetch, 2, "check overridden value"); is($cww->has_warning, 0, "check has_warning after fixing with override"); }; subtest "check warning with overridden computed value" => sub { my $xp = Test::Log::Log4perl->expect([ 'User', warn => qr/should be positive/ ]); my $cww = $root->fetch_element('compute_with_warning'); $av->store(2); $bv->store(1); $cww->fetch; is($cww->has_warning, 0, "computed value is fine"); $cww->store(-2); is($cww->has_warning, 1, "overridden value trigges a warning"); is($cww->fetch_standard, 3, "get standard value (triggers a compute)"); is($cww->fetch, -2, "overridden value is still there"); is($cww->has_warning, 1, "check that warning is still present"); is($cww->perform_compute, 3, "force a compute"); is($cww->fetch, -2, "overridden value is still there"); is($cww->has_warning, 1, "check that warning is still present"); }; subtest "check warning with modified compute_with_override_and_fix" => sub { my $xp = Test::Log::Log4perl->expect([ 'User', warn => qr/not default value/]); my $cwoaf = $root->fetch_element('compute_with_override_and_fix'); is($cwoaf->fetch, 'def value', "test compute_with_override_and_fix default value"); # generate the expected warning because value does not match /def/ $cwoaf->store('oops') ; is($cwoaf->fetch, 'oops', "test compute_with_override_and_fix value after fix"); is($cwoaf->has_warning, 1, "check if bad value has warnings"); $cwoaf->apply_fixes; is($cwoaf->fetch, 'def value', "test compute_with_override_and_fix value after fix"); is($cwoaf->has_warning, 0, "check if apply fix has cleaned up the warnings"); }; subtest "check warning when applying powerless fix" => sub { my $cwoapf = $root->fetch_element('compute_with_override_and_powerless_fix'); { my $xp = Test::Log::Log4perl->expect([ 'User', warn => qr/not good value/]); $cwoapf->apply_fixes; } is($cwoapf->fetch, '/dev/lcd0', "test default value after powerless fix"); }; foreach my $elem (qw/foo2 bar/) { foreach my $i (1..3) { my $step = $elem.' Licenses:booya short_name_from_above'.$i; my $v1 = $root->grab_value($step); is($v1,$elem,"test short_name with '$step'"); } } memory_cycle_ok( $model, "test memory cycles" ); done_testing; Config-Model-2.149/t/annotation.t0000644000175000017500000000743314170053137015250 0ustar domidomi# -*- cperl -*- use ExtUtils::testlib; use Test::More ; use Test::Memory::Cycle; use Config::Model; use Config::Model::Annotation; use Config::Model::Tester::Setup qw/init_test setup_test_dir/; use File::Path; use Data::Dumper; use 5.10.0; use warnings; no warnings qw(once); use strict; use lib 't/lib'; my ($model, $trace) = init_test(); my $wr_root = setup_test_dir(); my $inst = $model->instance( root_class_name => 'Master', 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'" ); $inst->clear_changes; my @annotate = map { [ $_ => "$_ annotation" ] } ( 'std_id', 'std_id', # test that 2 saves of same value is tracked once 'std_id:bc X', 'my_check_list', 'olist:0', 'olist:2', # this element is created, so 2 notifs are generated for this ); 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" ); } say "pending changes:\n".$inst->list_changes if $trace; is( $inst->needs_save, 5, "verify instance needs_save status after storing only annotations" ); $inst->clear_changes; 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" ); say "pending changes:\n".$inst->list_changes if $trace; is( $inst->needs_save, 2, "verify instance needs_save status after store/delete annotations" ); $inst->clear_changes; 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 $test_dir = $annotate_saver->dir; is( $test_dir, $wr_root.'/config-model', "check saved dir" ); my $test_file = $annotate_saver->file; is( $test_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 $test_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, "memory cycles"); done_testing; Config-Model-2.149/t/multi_warp_value.t0000644000175000017500000001035314170053137016450 0ustar domidomi# -*- cperl -*- use ExtUtils::testlib; use Test::More; use Test::Differences; use Test::Memory::Cycle; use Config::Model; use Config::Model::Tester::Setup qw/init_test/; use Storable qw/dclone/; use strict; use warnings; my ($model, $trace) = init_test(); 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" }; } } } # minimal set up to get things working 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, "memory cycle"); done_testing; Config-Model-2.149/t/term_ui.t0000644000175000017500000000620714170053137014540 0ustar domidomi# -*- cperl -*- use strict; use warnings; 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 = Term::ReadLine->new( 'Test' ); 1; } and ( eval { require Term::ReadLine::Gnu; 1; } or eval { require Term::ReadLine::Perl; 1; } ); if ($ok) { plan tests => 18; } else { plan skip_all => "Cannot load Term::ReadLine"; } } use Test::Memory::Cycle; use Config::Model; use Config::Model::Tester::Setup qw/init_test/; use Config::Model::TermUI; use warnings; use strict; use lib "t/lib"; use Data::Dumper; my ($model, $trace, $args) = init_test('interactive'); note("you can run the test in interactive mode by passing '--interactive' option, e.g. perl -Ilib t/term_ui.t --interactive"); my $inst = $model->instance( root_class_name => 'Master', 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 ($args->{interactive}) { $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 check clear delete desc description display dump fix help info 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'] ], [ [ '', 'fix ', 4 ], [ $root->get_element_names(), '!'] ], [ [ '','tree ', 5], ['std_id:ab', 'std_id:"abc def"', 'std_id:"abc hij"', 'std_id:bc', 'warp', 'slave_y'] ], [ [ 'std', 'tree std', 5 ], ['std_id:ab', 'std_id:"abc def"', 'std_id:"abc hij"', 'std_id:bc'] ], [ [ 'std', 'ls std', 3], ['std_id:', 'std_id:ab', 'std_id:"abc def"', 'std_id:"abc hij"', 'std_id:bc'] ], [ [ 'std_id:ab', 'ls std_id:ab', 3], [ ] ], [ [ '', 'info std_id:ab ', 15], ['Z', 'X', 'DX']], ); 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, "memory cycles"); Config-Model-2.149/t/node_get_set.t0000644000175000017500000000215714170053137015533 0ustar domidomi# -*- cperl -*- use ExtUtils::testlib; use Test::More; use Test::Memory::Cycle; use Config::Model; use Config::Model::Tester::Setup qw/init_test/; use warnings; use strict; use lib "t/lib"; my ($model, $trace) = init_test(); ok( 1, "compiled" ); my $inst = $model->instance( root_class_name => 'Master', 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, "memory cycle"); done_testing; Config-Model-2.149/t/model.t0000644000175000017500000000661114170053137014173 0ustar domidomi# -*- 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 Config::Model::Tester::Setup qw/init_test/; use Data::Dumper; use Log::Log4perl qw(:easy :levels); use strict; use warnings; my ($model, $trace) = init_test(); 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_clone($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' ], 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_clone($class_name); print "$class_name model:\n", Dumper($canonical_model) if $trace; memory_cycle_ok( $model, "memory cycles" ); done_testing; Config-Model-2.149/t/warped_id.t0000644000175000017500000001574414170053137015040 0ustar domidomi# -*- cperl -*- use ExtUtils::testlib; use Test::More; use Test::Memory::Cycle; use Config::Model; use Config::Model::Tester::Setup qw/init_test/; use strict; use warnings; my ($model, $trace) = init_test(); $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_keys => [ 0 .. 3 ], warp => { follow => [ '- version', '- macro' ], 'rules' => [ [ '2', 'C' ] => { max => 7, default_keys => [ 0 .. 7 ] }, [ '2', 'A' ] => { max => 7, default_keys => [ 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', level => 'hidden', # must also accept level and description here cargo => { type => 'leaf', value_type => 'string', warp => { follow => '- macro', 'rules' => { 'A' => { default => 'dumb string' }, } } }, warp => { follow => '- macro', 'rules' => { 'A' => { level => 'advanced', }, } }, }, 'multi_auto_create' => { type => 'hash', index_type => 'integer', min => 0, max => 3, auto_create_keys => [ 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, "memory cycle"); done_testing; Config-Model-2.149/t/cme-function.t0000644000175000017500000000335714170053137015466 0ustar domidomi# -*- cperl -*- use strict; use warnings; use Path::Tiny; use Test::More; use Config::Model qw/cme/; use Test::Log::Log4perl; Test::Log::Log4perl->ignore_priority("debug"); # pseudo root where config files are written by config-model my $wr_root = path('wr_root_p/cme'); # cleanup before tests $wr_root->remove_tree; my $wr_dir = $wr_root->child('popcon'); my $etc_dir = $wr_dir->child('etc'); my $conf_file = $etc_dir->child('popularity-contest.conf'); # put popcon data in place my @orig = ; $etc_dir->mkpath; $conf_file->spew(@orig); { my $instance = cme( application => 'popcon', root_dir => $wr_dir, canonical => 1, ); ok($instance,"new instance created"); } { my $instance = cme('popcon'); ok($instance,"found instance created above"); # test minimal modif (re-order) $instance->save(force => 1); ok(1,"data saved"); } my $new_data = $conf_file->slurp; like $new_data, qr/cme/, "updated header"; like $new_data, qr/yes"\nMY/, "reordered file"; unlike $new_data, qr/removed/, "double comment is removed"; { my $tlog = Test::Log::Log4perl->expect( ['Verbose.Loader', info => qr/command/], ['User', info => qr/Changes applied/ ], ['Instance', ( info => qr/write_back called/ ) x 2 ], ); cme('popcon')->modify("PARTICIPATE=no"); } ok(1,"load done and saved"); $new_data = $conf_file->slurp; like $new_data, qr/PARTICIPATE="no"/, "updated config data"; done_testing; __END__ # 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 DAY="6" Config-Model-2.149/t/apply_fix.t0000644000175000017500000001303114170053137015060 0ustar domidomi# -*- cperl -*- use warnings; use Test::More; use Test::Memory::Cycle; use Config::Model; use Config::Model::Value; use Config::Model::Tester::Setup qw/init_test/; use Data::Dumper; use Test::Log::Log4perl; use Test::Differences; use strict; use 5.10.1; Test::Log::Log4perl->ignore_priority("info"); my ($model, $trace) = init_test(); # minimal set up to get things working $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;' }, }, }, # test data deletion from Dpkg/Copyright Disclaimer # using undef disclaimer_fix_with_undef => { type => 'leaf', value_type => 'string', warn_if_match => { 'dh-make-perl' => { fix => '$_ = undef ;', msg => 'Disclaimer contains dh-make-perl boilerplate' } } }, # same test as above using _store method disclaimer_fix_with_delete => { type => 'leaf', value_type => 'string', warn_if_match => { 'dh-make-perl' => { fix => '$self->store(undef) ;', msg => 'Disclaimer contains dh-make-perl boilerplate' } } }, 'chained-fix' => { type => 'leaf', value_type => 'uniline', 'warn_if_match' => { '^\s' => { 'msg' => 'leading white space', 'fix' => 's/^\s+//;' }, }, warn_unless_match => { '^https://' => { msg => 'secure http', fix => 's!^http://!https://!' }, '^https?://bugs\.debian\.org/' => { msg => 'unknown host', fix => 's!https?://[^/]*!https://bugs.debian.org!' } }, }, ] ); $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; my %expected_changes = ( long => [], with_delete => [], with_undef => [] ); foreach my $w (qw/a b c/) { my $foo = Test::Log::Log4perl->expect( ignore_priority => info => [ 'User', warn => qr/deprecated in favor of Debian GNU/, warn => qr/Line too long/, warn => qr/leading white space/, warn => qr/secure http/, warn => qr/unknown host/, ( warn => qr/dh-make-perl/) x 2 # 2 disclaimer parameters ] ); $root->load (qq!my_broken_node_$w fix-gnu="Debian GNU/Linux for $w"! . qq! fix-long="$w is way too long"! . qq! chained-fix=" http://floc/$w$w$w"! . qq! disclaimer_fix_with_undef="blah dh-make-perl blah"! . qq! disclaimer_fix_with_delete="blah dh-make-perl blah"! ); push @{$expected_changes{long}}, "my_broken_node_$w fix-long: '$w is way too long' -> '$w is way' # applied fix for :Line too long"; push @{$expected_changes{with_delete}}, "my_broken_node_$w disclaimer_fix_with_delete deleted value: \'blah dh-make-perl blah\'"; push @{$expected_changes{with_undef}}, "my_broken_node_$w disclaimer_fix_with_undef deleted value: \'blah dh-make-perl blah\' # applied fix for :Disclaimer contains dh-make-perl boilerplate"; } print $root->dump_tree if $trace; foreach my $filter (sort keys %expected_changes) { $inst->clear_changes; $root->apply_fixes($filter); eq_or_diff([$inst->list_changes], $expected_changes{$filter}, qq!change list for $filter apply_fix! ); } foreach (qw/a b c/) { is( $root->grab_value("my_broken_node_$_ fix-long"), "$_ is way", "check that '$_' long stuff was fixed" ); is( $root->grab_value("my_broken_node_$_ disclaimer_fix_with_undef"), undef, "check that '$_ disclaimer_fix_with_undef' was fixed" ); is( $root->grab_value("my_broken_node_$_ disclaimer_fix_with_delete"), undef, "check that '$_ disclaimer_fix_with_delete' was fixed" ); is( $root->grab_value("my_broken_node_$_ fix-gnu"), "Debian GNU/Linux for $_", "check that '$_' gnu stuff was NOT fixed" ); } $inst->clear_changes; $root -> apply_fixes; foreach (qw/a b c/) { is( $root->grab_value("my_broken_node_$_ chained-fix"), "https://bugs.debian.org/$_$_$_", "check that $_ secure url was fixed" ); } my @changes = $inst->list_changes; is(scalar @changes, 3 * 4 , qq!number of changes applied for chained-fix apply_fix! ); print $root->dump_tree if $trace; memory_cycle_ok($model, "memory cycle"); done_testing; Config-Model-2.149/t/instance.t0000644000175000017500000000543714170053137014704 0ustar domidomi# -*- cperl -*- use warnings; use ExtUtils::testlib; use Test::More; use Test::Warn; use Test::Memory::Cycle; use Config::Model; use Config::Model::Tester::Setup qw/init_test/; use strict; use lib "t/lib"; use Test::Log::Log4perl; my ($model, $trace) = init_test(); $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" ); ok( $model->instance(name => 'test1'), "check that instance can be retrieved by name"); $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->root_dir->stringify, 'foobar', "test config root 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'); my $wt = Test::Log::Log4perl->get_logger("User"); Test::Log::Log4perl->start(ignore_priority => "info"); $wt->warn(qr/should not match/); $wt->warn(qr/should match/); $wip->store('foobar'); $wup->store('bar'); Test::Log::Log4perl->end("test warn_if and 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', 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" ); memory_cycle_ok($model, "memory cycles"); done_testing; Config-Model-2.149/t/get_info.t0000644000175000017500000000357514170053137014673 0ustar domidomi# -*- cperl -*- use ExtUtils::testlib; use Test::More; use Test::Differences; use Test::Memory::Cycle; use Config::Model; use Config::Model::Tester::Setup qw/init_test/; use warnings; use strict; use lib "t/lib"; use utf8; use open qw(:std :utf8); # undeclared streams in UTF-8 my ($model, $trace) = init_test(); $model->load(Master => 'Config/Model/models/Master.pl'); ok( 1, "loaded big_model" ); my $inst = $model->instance( root_class_name => 'Master', 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 - ' . 'my_check_list=toto my_reference="titi"'; ok( $root->load( step => $step ), "set up data in tree with '$step'" ); my @setup = ( [ '!' => ['type: node','class name: Master' ] ], [ std_id => ['type: hash', 'index: string', 'cargo: node', 'cargo class: SlaveZ'] ], [ 'std_id:ab' => ['type: node', 'class name: SlaveZ']], [ 'std_id:ab X' => [ 'type: enum (Av,Bv,Cv)']], [ lista => [ 'type: list', 'index: integer','cargo: leaf', 'leaf value type: string' ]], [ olist => [ 'type: list','index: integer', 'cargo: node','cargo class: SlaveZ' ]], [ my_check_list => ['type: check_list','refer_to: - hash_a + ! hash_b','ordered: no']], [ a_boolean => [ 'type: boolean' ]], [ yes_no_boolean => [ 'type: boolean','upstream_default value: yes', 'write_as: no yes' ]], [ my_reference => ['type: reference','reference to: - hash_a + ! hash_b']], ); foreach my $test (@setup) { my ($path, $expect) = @$test; my @info = $root->grab($path)->get_info; eq_or_diff( \@info, $expect , "check '$path' info " ); } memory_cycle_ok($model, "check memory cycles"); done_testing; Config-Model-2.149/t/smooth_upgrade.t0000644000175000017500000001316314170053137016113 0ustar domidomi# -*- cperl -*- use ExtUtils::testlib; use Test::More; use Test::Exception; use Test::Memory::Cycle; use Test::Log::Log4perl; use Config::Model; use Config::Model::Tester::Setup qw/init_test/; use Config::Model::Value; use strict; use warnings; Test::Log::Log4perl->ignore_priority("info"); my ($model, $trace) = init_test(); $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; { my $foo = Test::Log::Log4perl->expect([ User => warn => qr/Element 'deprecated_p' of node 'Master' is deprecated/ ]); $dp = $root->fetch_element('deprecated_p'); } 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" ); { # check warning when fetching deprecated element my $foo = Test::Log::Log4perl->expect([ User => warn => qr/Element 'old_url' of node 'UrlMigration' is deprecated/ ]); $dp = $uroot->fetch_element('old_url')->store($url); } $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" ); done_testing; Config-Model-2.149/t/author-critic.t0000644000175000017500000000074014170053137015645 0ustar domidomi#!perl # # This file is part of Config-Model # # This software is Copyright (c) 2005-2022 by Dominique Dumont. # # This is free software, licensed under: # # The GNU Lesser General Public License, Version 2.1, February 1999 # BEGIN { unless ($ENV{AUTHOR_TESTING}) { print qq{1..0 # SKIP these tests are for testing by the author\n}; exit } } use strict; use warnings; use Test::Perl::Critic (-profile => "perlcritic.rc") x!! -e "perlcritic.rc"; all_critic_ok(); Config-Model-2.149/t/obj_tree_scanner.t0000644000175000017500000003126614170053137016401 0ustar domidomi# -*- cperl -*- use ExtUtils::testlib; use Test::More; use Test::Memory::Cycle; use Config::Model; use Config::Model::Tester::Setup qw/init_test/; use Config::Model::ObjTreeScanner; use Test::Differences; use Data::Dumper; use warnings; use strict; use lib "t/lib"; 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 ($model, $trace) = init_test(); my $inst = $model->instance( root_class_name => 'Master', 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 a_boolean yes_no_boolean 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 a_boolean yes_no_boolean 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 a_boolean disp_leaf Master element yes_no_boolean 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 a_boolean disp_leaf Master element yes_no_boolean 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, "memory cycle"); done_testing; Config-Model-2.149/t/check_list.t0000644000175000017500000005144514170053137015210 0ustar domidomi# -*- cperl -*- use warnings; use strict; use ExtUtils::testlib; use Test::More; use Test::Differences; use Test::Memory::Cycle; use Test::Log::Log4perl; use Test::Exception; use Config::Model; use Config::Model::Tester::Setup qw/init_test/; Test::Log::Log4perl->ignore_priority("info"); my ($model, $trace) = init_test(); # minimal set up to get things working $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" ); subtest 'test _store method' => sub { # test with the polymorphic 'store' method my @test_args = ( [ [ 'S', 1, 'yes' ], 1, ['S'] ], [ [ 'A', 1, 'yes' ], 2, ['A','S'] ], [ [ 'A', 0, 'yes' ], 1, ['S'] ], [ [ 'bug', 1, 'skip' ], 1, ['S'] ], ); foreach my $test_arg_ref ( @test_args) { my ($args, $nb, $expect) = @$test_arg_ref; $cl->_store( @$args ); ok( 1, "test _store method with @$args" ); @got = $cl->get_checked_list; is( scalar @got, $nb, "test nb of elt in check_list after _store" ); is_deeply( \@got, $expect, "test get_checked_list after _store" ); $inst->clear_changes; } }; subtest 'test _store warning' => sub { my $foo = Test::Log::Log4perl->expect( ignore_priority => 'info', [ 'User', warn => qr/Unknown check_list item/ ] ); $cl->_store('bug-skipped', 1, 'skip'); }; throws_ok { $cl->_store('bug-error', 1, 'yes') } qr/wrong value/, 'test _store error'; subtest 'test store method' => sub { # test with the polymorphic 'store' method my @store_args = ( [ 'S,T,O,R,E' ], [ value => 'S,T , O, R, E' ], [ 'S,O,T,R,E', check => 'yes' ], [ value => 'S,T , O, R, E', check => 'yes' ], [ 'S,T,O,R,E,bug', check => 'skip' ], ); foreach my $test_arg ( @store_args) { $cl->store( @$test_arg ); ok( 1, "test store method with @$test_arg" ); @got = $cl->get_checked_list; is( scalar @got, 5, "test nb of elt in check_list after set" ); is_deeply( \@got, [sort qw/S T O R E/], "test get_checked_list after set" ); $inst->clear_changes; } }; $cl->clear; subtest "test set method and reported changes" => sub { my @set_args = ( # set string, changes , content after changes [ 'A,B' => 'A:1 B:1',qw/A B/], [ 'A,B,C' => 'C:1', qw/A B C/], [ 'A,C,D' => 'B:0 D:1', qw/A C D/], ); while (@set_args) { my $test = shift @set_args; my ($set_string, $expected_changes, @expected_content) = @$test; $cl->set( '', $set_string ); ok( 1, "test set method with $set_string" ); @got = $cl->get_checked_list; is_deeply( \@got, \@expected_content, "test get_checked_list content after set" ); is( $inst->needs_save, !!$expected_changes, "verify instance needs_save after set" ); print join( "\n", $inst->list_changes("\n") ), "\n" if $trace; eq_or_diff([$inst->list_changes], ["choice_list: set_checked_list $expected_changes"], "check change message after set check list to $set_string"); $inst->clear_changes; } }; $cl->clear; $inst->clear_changes; my @set = sort qw/A C Z V Y/; subtest "test get_arguments" => sub { my @set_args = ( \@set, [ \@set ], [ \@set , check => 'yes' ], ); foreach my $test_arg ( @set_args) { my ($list, $check, $args) = $cl->get_arguments(@$test_arg); ok( 1, "test set_checked_list" ); eq_or_diff($list, \@set, "test passed list"); } }; subtest 'test set_checked_list method' => sub { my @set_args = ( \@set, [ \@set ], [ \@set , check => 'yes' ], [ [ sort qw/A C Z V Y bug/ ] , check => 'skip' ], ); foreach my $test_arg ( @set_args) { $cl->set_checked_list(@$test_arg); 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; $cl->clear; $inst->clear_changes; } }; subtest 'test set_checked_list error handling' => sub { # bug is not an allowed value throws_ok { $cl->set_checked_list(qw/A bug/ ) } qr/wrong value/, 'got exception'; }; subtest 'test behavior when skipping bad value' => sub { my $foo = Test::Log::Log4perl->expect( ignore_priority => 'info', ['User', warn => qr/Unknown check_list item/ ] ); $cl->set_checked_list([qw/A bug/], check => 'skip'); }; $cl->clear; $inst->clear_changes; # test global get and set as hash $cl->set_checked_list(@set); $hr = $cl->get_checked_list_as_hash; for ( 'A' .. 'Z' ) { $expect{$_} = 0 } for (@set) { $expect{$_} = 1 } 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" ); @got = $dflist->get_checked_list(mode =>'custom'); is_deeply( \@got, [ ], "test custom data of choice_list_with_default" ); is($dflist->has_data, 0, "choice_list_with_default has no data"); $dflist->check('C'); $dflist->uncheck('D'); @got = $dflist->get_checked_list; is_deeply( \@got, [ 'A', 'C' ], "test default of choice_list_with_default" ); is($dflist->has_data, 1, "choice_list_with_default has data"); @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" ); @got = $dflist->get_checked_list('backend'); is_deeply( \@got, [ 'A', 'C' ], "fetch with backend mode for 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" ); is($wud->has_data, 0, "test checklist has data"); @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; Config-Model-2.149/t/dump_as_data.t0000644000175000017500000001556714170053137015526 0ustar domidomi# -*- cperl -*- use ExtUtils::testlib; use Test::More; use Test::Memory::Cycle; use Test::Log::Log4perl; use Config::Model; use Config::Model::Tester::Setup qw/init_test/; use warnings; use strict; use lib "t/lib"; use boolean; Test::Log::Log4perl->ignore_priority("info"); my ($model, $trace) = init_test(); my $inst = $model->instance( root_class_name => 'Master', model_file => 'dump_load_model.pl', 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 - bool_list=0,1 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; note("steps are $step") if $trace; ok( $root->load( step => $step ), "set up data in tree" ); # 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', bool_list => [ false, true ], '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" ); subtest "check default mapping of boolean value type" => sub { my $data = $root->dump_as_data( full_dump => 0 ); for (0,1) { is($data->{bool_list}[$_], $_, "Perl data value of bool_list:$_ "); is(ref $data->{bool_list}[$_], '', "Perl data of bool_list:$_ is not a ref"); } }; subtest "check mapping of boolean value type to Perl boolean" => sub { my $data = $root->dump_as_data( full_dump => 0, to_boolean => sub { boolean(shift) } ); for (0,1) { isa_ok($data->{bool_list}[$_], "boolean", "Perl data of bool_list:$_ "); }; }; subtest "check mapping of boolean value type to Perl boolean" => sub { plan skip_all => "JSON PP boolean behavior not yet checked"; my $data = $root->dump_as_data( full_dump => 0, to_boolean => 'JSON::PP::Boolean' ); for (0,1) { isa_ok($data->{bool_list}[$_], "JSON::PP::Boolean", "Perl data of bool_list:$_ "); } }; # 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(mode => 'user'); 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(mode => 'user'); 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" ); subtest "test ordered_hash warnings" => sub { my $tw = Test::Log::Log4perl->get_logger("Tree.Element.Id.Hash"); Test::Log::Log4perl->start(ignore_priority => "info"); $tw->warn(qr/order is not defined/); # load 2 items in ordered_hash without __order produces a warning"; $root->load_data( { ordered_hash => { y => '2', 'x' => '3' }}); # load one item in ordered_hash without __order produce no warning"; $root->load_data( { ordered_hash => { 'x' => '3' }}); Test::Log::Log4perl->end("warnings without __order"); }; # 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} }, __order => [qw/y x z/] }; $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/y 2 x 3 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(mode => 'user'); 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, "memory cycles"); done_testing; Config-Model-2.149/t/load.t0000644000175000017500000007042514170053137014016 0ustar domidomi# -*- cperl -*- use ExtUtils::testlib; use Test::More; use Test::Exception; use Test::Differences; use Test::Memory::Cycle; use Config::Model; use Config::Model::Tester::Setup qw/init_test/; use Test::Log::Log4perl; use strict; use warnings; Test::Log::Log4perl->ignore_priority("info"); use lib "t/lib"; my ($model, $trace) = init_test(); # See caveats in Test::More doc my $builder = Test::More->builder; binmode $builder->output, ":encoding(UTF-8)"; binmode $builder->failure_output, ":encoding(UTF-8)"; binmode $builder->todo_output, ":encoding(UTF-8)"; binmode STDOUT, ':encoding(UTF-8)'; binmode STDERR, ':encoding(UTF-8)'; ok( 1, "compiled" ); subtest "mega regexp" => sub { my $big_list = '"dh-autoreconf","pkg-config","debhelper-compat (= 12)","dh-autotools (> 3)"'; # test mega regexp, 'x' means undef my @regexp_test = ( # id_operation leaf_operation # string elt op (param) id op (param) val note [ 'a', [ 'a', 'x', 'x', 'x', 'x', 'x', 'x', 'x' ] ], [ '#C', [ 'x', 'x', 'x', 'x', 'x', 'x', 'x', 'C' ] ], [ '#"m C"', [ 'x', 'x', 'x', 'x', 'x', 'x', 'x', '"m C"' ] ], [ 'a=b', [ 'a', 'x', 'x', 'x', '=', 'x', 'b', 'x' ] ], [ 'a=a~', [ 'a', 'x', 'x', 'x', '=', 'x', 'a~', 'x' ] ], [ 'a="~"', [ 'a', 'x', 'x', 'x', '=', 'x', '"~"', 'x' ] ], [ 'a=.foo(bar)', [ 'a', 'x', 'x', 'x', '=.foo','bar', 'x', 'x' ] ], [ 'a=.foo("b r")', [ 'a', 'x', 'x', 'x', '=.foo','"b r"', 'x', 'x' ] ], [ 'a=.json(dir/foo.json/b/a)', [ 'a', 'x', 'x', 'x', '=.json','dir/foo.json/b/a', 'x', 'x' ] ], # path + vector [ 'a-z=b', [ 'a-z','x', 'x', 'x', '=', 'x', 'b', 'x' ] ], [ "a=\x{263A}", [ 'a', 'x', 'x', 'x', '=', 'x', "\x{263A}", 'x' ] ], # utf8 smiley [ 'a.=b', [ 'a', 'x', 'x', 'x', '.=', 'x', 'b', 'x' ] ], [ "a.=\x{263A}", [ 'a', 'x', 'x', 'x', '.=', 'x', "\x{263A}", 'x' ] ], # utf8 smiley [ 'a="b=c"', [ 'a', 'x', 'x', 'x', '=', 'x', '"b=c"', 'x' ] ], [ 'a="b=\"c\""', [ 'a', 'x', 'x', 'x', '=', 'x', '"b=\"c\""','x' ] ], [ 'a=~/a/A/', [ 'a', 'x', 'x', 'x', '=~', 'x', '/a/A/', 'x' ] ], # subst on value [ 'a=b#B', [ 'a', 'x', 'x', 'x', '=', 'x', 'b', 'B' ] ], [ 'a#B', [ 'a', 'x', 'x', 'x', 'x', 'x', 'x', 'B' ] ], [ 'a#"b=c"', [ 'a', 'x', 'x', 'x', 'x', 'x', 'x', '"b=c"' ] ], # id_operation leaf_operation # string elt op (param) id op (param) val note [ 'a:b=c', [ 'a', ':', 'x', 'b', '=', 'x', 'c', 'x' ] ], # fetch and assign elt [ 'a:"b\""="\"c"', [ 'a', ':', 'x', '"b\""', '=', 'x', '"\"c"', 'x' ] ], # fetch and assign elt with quotes [ 'a:~', [ 'a', ':~', 'x', 'x', 'x', 'x', 'x', 'x' ] ], # loop on matched value [ 'a:~.=b', [ 'a', ':~', 'x', 'x', '.=', 'x', 'b', 'x' ] ], # loop on matched value [ 'a:~/b.*/', [ 'a', ':~', 'x', '/b.*/', 'x', 'x', 'x', 'x' ] ], # loop on matched value [ 'a:~"b.*"', [ 'a', ':~', 'x', '"b.*"', 'x', 'x', 'x', 'x' ] ], # loop on matched value [ 'a:~/b.*/.="\"a"', [ 'a', ':~', 'x', '/b.*/', '.=', 'x', '"\"a"', 'x' ] ], # loop on matched value and append [ 'a:~"b.*".="\"a"', [ 'a', ':~', 'x', '"b.*"', '.=', 'x', '"\"a"', 'x' ] ], # loop on matched value and append [ 'a:~/^\w+$/', [ 'a', ':~', 'x', '/^\w+$/', 'x', 'x', 'x', 'x' ] ], # loop on matched value [ 'a:="dod@foo.com"', [ 'a', ':=', 'x', '"dod@foo.com"','x', 'x', 'x', 'x' ] ], # set list [ 'a:=b,c,d', [ 'a', ':=', 'x', 'b,c,d', 'x', 'x', 'x', 'x' ] ], # set list [ 'a=b,c,d', [ 'a', 'x', 'x', 'x', '=', 'x', 'b,c,d', 'x' ] ], # set list old style [ 'm:=a,"a b "', [ 'm', ':=', 'x', 'a,"a b "', 'x', 'x', 'x', 'x' ] ], # set list with quotes [ 'm:="a b ",c', [ 'm', ':=', 'x', '"a b ",c', 'x', 'x', 'x', 'x' ] ], # set list with quotes [ 'm:="a b","c d"', [ 'm', ':=', 'x', '"a b","c d"', 'x', 'x', 'x', 'x' ] ], # set list with quotes [ "m:=$big_list", [ 'm', ':=', 'x', $big_list, 'x', 'x', 'x', 'x' ] ], # set list with quotes [ 'm=a,"a b "', [ 'm', 'x', 'x', 'x', '=', 'x', 'a,"a b "', 'x' ] ], # set list with quotes,old style # id_operation leaf_operation # string elt op (param) id op (param) val note [ 'a:b#C', [ 'a', ':', 'x', 'b', 'x', 'x', 'x', 'C' ] ], # fetch elt and add comment [ 'a:"b\""#"\"c"', [ 'a', ':', 'x', '"b\""', 'x', 'x', 'x', '"\"c"' ] ] , # fetch elt and add comment with quotes [ 'a:b=c#C', [ 'a', ':', 'x', 'b', '=', 'x', 'c', 'C' ] ], # fetch and assign elt and add comment [ 'a:-', [ 'a', ':-', 'x', 'x', 'x', 'x', 'x', 'x' ] ], # empty list [ 'a:-b', [ 'a', ':-', 'x', 'b', 'x', 'x', 'x', 'x' ] ], # remove id b [ 'a:-=b', [ 'a', ':-=','x', 'b', 'x', 'x', 'x', 'x' ] ], # remove value b from list or hash [ 'a:-~/b/', [ 'a', ':-~','x', '/b/', 'x', 'x', 'x', 'x' ] ], # remove value matching stuff [ 'a:=~s/b/c/g', [ 'a', ':=~','x', 's/b/c/g', 'x', 'x', 'x', 'x' ] ] , # subsitute value value matching stuff # id_operation leaf_operation # string elt op (param) id op (param) val note [ 'a:@', [ 'a', ':@', 'x', 'x', 'x', 'x', 'x', 'x' ] ], # sort list [ 'a:.b', [ 'a', ':.b','x', 'x', 'x', 'x', 'x', 'x' ] ], # function called on elt [ 'a:.b(foo)', [ 'a', ':.b','foo', 'x', 'x', 'x', 'x', 'x' ] ], # idem with param [ 'a:c', [ 'a', ':>', 'x', 'c', 'x', 'x', 'x', 'x' ] ], # unshift value [ 'a:b b)")',[ 'a', ':.b','"foo(a > b)"','x', '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 => 'dump_load_model.pl', instance_name => 'test1' ); ok( $inst, "created dummy instance" ); my $root; subtest "check with embedded \n" => sub { # also check that instance can load before config_root is called my $step = qq!#"root cooment " std_id:ab X=Bv -\na_string="titi and\nfoo" !; ok( $inst->load( step => $step ), "load steps with embedded \\n" ); $root = $inst->config_root; is( $root->fetch_element('a_string')->fetch, "titi and\nfoo", "check a_string" ); }; subtest "check with embedded \n and \\n" => sub { my $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" ); }; subtest "check search up for element" => sub { my $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" ); }; subtest "check that : action fails on a leaf" => sub { my $step = qq!a_string:toto!; # should blow up throws_ok { $root->load( step => $step ) ; } qr/f/, "use ':' on a leaf"; }; subtest "test apply regexp" => sub { my $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" ); }; subtest "test apply regexp with embedded spaces" => sub { my $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" ); }; subtest "check with embedded quotes" => sub { my $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" ); }; subtest "check with embedded utf8" => sub { my $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" ); }; subtest "check with embedded literal \n that are switched with real \n" => sub { # note: using q and not qq my $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' ); }; subtest "check with embedded comma and quotes" => sub { my $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" ); }; subtest "check that we can go to root node starting from below" => sub { my $stdab = $root->grab("std_id:ab"); $stdab->load("! a_string=titi"); ok( 1, "go to root node starting from below" ); # check that we can put an pseudo root $stdab->load(steps => "! X=Bv", caller_is_root => 1); ok( 1, "go to pseudo root node" ); throws_ok { $stdab->load(steps => "- std_id:fg X=Bv", caller_is_root => 1); } qr/too many '-'/, "cannot exit pseudo root with '-'"; }; subtest "test load with warped_node below root (used to fail)" => sub { ok( $root->load( step => 'tree_macro=XZ' ), "Set tree_macro to XZ" ); my $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" ); }; subtest "use indexes with white spaces" => sub { my $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" ); }; subtest "check for load errors" => sub { my $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 = 'listb:=b,c,d,,f,"",h,0'; throws_ok { $root->load( step => $step ); } qr/comma/, "load wrong '$step'"; }; subtest "check complex load string on many lists" => sub { my $step = 'lista:=a,b,c,d lista:4=e olist:0 X=Av - olist:1 X=Bv - 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' ); foreach ( 0, 1 ) { is( $olist->fetch_with_id($_)->config_class_name, 'SlaveZ', "check list element $_ class" ); } my $lista = $root->fetch_element('lista'); isa_ok( $lista, 'Config::Model::ListId', 'check lista class' ); foreach ( 0, 1 ) { isa_ok( $lista->fetch_with_id($_), 'Config::Model::Value', "check lista element $_ class" ); } 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/; foreach ( 0 .. $#expect ) { is( $lista->fetch_with_id($_)->fetch, $expect[$_], "check lista element $_ content" ); } my $listb = $root->fetch_element('listb'); @expect = ( qw/b c d/, 'f', '', 'h', '0' ); foreach ( 0 .. $#expect ) { is( $listb->fetch_with_id($_)->fetch, $expect[$_], "check listb element $_ content" ); } }; subtest "check quoted string and list assignment" => sub { my $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' ); my @expect = qw/a b c d e/; my $lista = $root->fetch_element('lista'); foreach ( 0 .. 4 ) { is( $lista->fetch_with_id($_)->fetch, $expect[$_], "check lista element $_ content" ); } }; subtest "check complex hash index" => sub { my $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" hash_a:empty'; ok( $root->load( step => $step, ), "load : '$step'" ); is_deeply( [ sort $root->fetch_element('hash_a')->fetch_all_indexes ], [ 'a', 'a b ', 'b', 'empty' ], "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' ); }; subtest "check quoted values" => sub { my $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'" ); my $lista = $root->fetch_element('lista'); is( $lista->fetch_with_id(1)->fetch, 'a "b" ', "test value loaded by '$step'" ); }; subtest "test that lista~a complains about non numeric index" => sub { my $step = 'lista~a'; throws_ok { $root->load( step => $step ); } "Config::Model::Exception::User", "load wrong '$step'"; }; subtest "use new and old notation to delete elements" => sub { my $step = 'lista:-1 hash_a~"a b "'; ok( $root->load( step => $step, ), "load : '$step'" ); my $lista = $root->fetch_element('lista'); is( $lista->fetch_with_id(1)->fetch, undef, "test list value loaded by '$step'" ); my $elt = $root->fetch_element('hash_a')->fetch_with_id('a b '); is( $elt->fetch, undef, "test hash value loaded by '$step'" ); }; subtest "test append mode" => sub { $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"'); my $lista = $root->fetch_element('lista'); 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" ); }; subtest "test loop mode" => sub { $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:.foreach_match("/^\w+$/") DX=Bv - int_v=9'); $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" ); }; subtest "test annotation setting" => sub { 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" ); } }; subtest "test remove by value and remove by matched value" => sub { $root->load('lista:=a,b,c,d,foo lista:-=b lista:-~/oo/'); my $lista = $root->fetch_element('lista'); eq_or_diff( [ $lista->fetch_all_values ], [qw/a c d/], "removed value from list" ); }; subtest "test substitution" => sub { $root->load('lista:=Foo1,foo2,bar lista:=~s/foo/doh/i'); my $lista = $root->fetch_element('lista'); 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" ); }; subtest "test function call in load string" => sub { my $lista = $root->fetch_element('lista'); $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" ); }; subtest "load with check set to no" => sub { my $list = $root->fetch_element('int_list_with_max'); throws_ok { $root->load(steps => 'int_list_with_max:=1,5,12'); } qr!max limit!, "cannot load value > max with default check value"; $root->load(steps => 'int_list_with_max:=1,5,12', check => 'no'); eq_or_diff( [ $list->fetch_all_values(check => 'no') ], [qw/1 5 12/], "load without check" ); $root->load(steps => 'int_list_with_max:.clear'); { my $xp = Test::Log::Log4perl->expect( ignore_priority => "info", ['User', warn => qr/value 12 > max limit/] ); $root->load(steps => 'int_list_with_max:=1,5,12', check => 'skip'); } eq_or_diff( [ $list->fetch_all_values ], [qw/1 5/], "load with check skip" ); }; subtest "test insert_before" => sub { my $lista = $root->fetch_element('lista'); $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/" ); }; subtest "test sort and insort" => sub { my @set1 = qw/c1 e i1 j1 p1/; my @set2 = qw/a2 z2 d2 e b2 k2/; my $lista = $root->fetch_element('lista'); $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 insort on ordered hash $root->load('ordered_hash:.insort(d,"dv")') ; eq_or_diff( [$oh->fetch_all_indexes()],[qw/a b d/], "check sorted keys after insort") ; # test insort on ordered hash of node my $ohon = $root->fetch_element('ordered_hash_of_node'); $root->load('ordered_hash_of_node:g aa2="g aa2 val" - ordered_hash_of_node:.insort(d) aa2="d aa2 val"'); eq_or_diff( [$ohon->fetch_all_indexes()],[qw/d g/], "check sorted keys") ; }; subtest "test combination of annotation plus load and some utf8" => sub { my $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" ); }; subtest "test element with embedded dash" => sub { $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" ); }; subtest "test deep copy" => sub { $root->load("std_id:.copy(ab,copy)"); is( $root->grab_value('std_id:copy X-Y-Z'), "Av", "check hash copy" ); is( $root->grab_value('lista:5'), 'e' , "list copy" ); $root->load("lista:.copy(1,5)"); is( $root->grab_value('lista:5'), 'b2' , "list copy" ); }; subtest "test clear instruction" => sub { $root->load("hash_a:.clear"); is( $root->grab('hash_a')->has_data, 0 , "cleared hash" ); $root->load("lista:.clear"); is( $root->grab('lista')->has_data, 0 , "cleared list" ); }; subtest "test load data from file" => sub { $root->load("a_string=.file(README.md)"); like( $root->grab_value('a_string'), qr/# What is Config-Model project/, "slurp README.md file"); }; subtest "test load data from JSON file" => sub { $inst->clear_changes; $root->load('a_string=.json("t/lib/load-data.json/foo/bar")'); is( $root->grab_value('a_string'), "bar json value", "extract data from json file"); $root->load('listc:.json("t/lib/load-data.json/foo_array")'); is( $root->grab_value('listc:0'), "bar", "extract array data from json file 1/2"); is( $root->grab_value('listc:1'), "baz", "extract array data from json file 2/2"); is( $inst->needs_save, 3, "verify instance needs_save after storing 3 values" ); throws_ok { $root->load('a_string=.json(t/lib/dummy.json/foo/bar)'); } qr!Cannot find file in t/lib/dummy.json/foo/bar!, "throws error on dummy json file: check error message"; throws_ok { $root->load('a_string=.json(t/lib/dummy.json/foo/bar)'); } qr!a_string=\.json\(t/lib/dummy\.json/foo/bar\)!, "throws error on dummy json file: check reported command"; }; subtest "test load data from YAML file" => sub { $root->load('a_string=.yaml("t/lib/load-data.yaml/0/foo/bar")'); is( $root->grab_value('a_string'), "bar yaml value", "extract data from yaml file"); }; subtest "load data from environment" => sub { my $expect = $ENV{TEST_CONFIG_MODEL_LOADER} = 'plop'; $root->load("a_string=.env(TEST_CONFIG_MODEL_LOADER)"); is( $root->grab_value('a_string'), 'plop', "set value from environment"); }; subtest "test some errors cases" => sub { my %errors = ( 'std_id' => qr/Missing key/, 'olist' => qr/Wrong assignment/, 'std_id:Apache-2.0 X=Av' => qr/spurious char/, 'std_id:-Apache-2.0 X=Av' => qr/spurious char/, ); 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; Config-Model-2.149/t/fuse_ui.t0000644000175000017500000001114714170053137014532 0ustar domidomi# -*- cperl -*- use ExtUtils::testlib; use List::MoreUtils qw/any/; use Test::More; use Path::Tiny; use Test::Memory::Cycle; use Config::Model; use Config::Model::Tester::Setup qw/init_test setup_test_dir/; use Config; use warnings; use strict; use lib "t/lib"; # 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 kernel module is loaded: $@"; } if ( not any {/fuse/} @lsmod ) { plan skip_all => "fuse kernel module is not loaded"; } if ( system(q!bash -c 'type -p fusermount' > /dev/null!) != 0 ) { 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; } # 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 ($model, $trace, $args) = init_test('fuse_debug'); my $wr_root = setup_test_dir(); my $fused = $wr_root->child('fused'); $fused->mkpath( { mode => oct(755) } ); $model->load( Master => 'Config/Model/models/Master.pl' ); $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 => $args->{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(); for ( @std_id_elements ) { s(/){$dir_char_mockup}g; }; 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" ); Config-Model-2.149/t/array_id.t0000644000175000017500000005017314170053137014667 0ustar domidomi# -*- cperl -*- use ExtUtils::testlib; use Test::More; use Test::Exception; use Test::Differences; use Test::Memory::Cycle; use Test::Log::Log4perl; use Config::Model; use Config::Model::AnyId; use strict; use warnings; use Config::Model::Tester::Setup qw/init_test/; Test::Log::Log4perl->ignore_priority("info"); my ($model, $trace) = init_test(); 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', match => '^.{1,5}$', }, }, 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", gist => '{X} and {Y}', element => [ [qw/X Y Z/] => { type => 'leaf', value_type => 'enum', choice => [qw/Av Bv Cv/] }, ] ); ok( 1, "config classes created" ); my ($inst,$root); subtest "array initialisation" => sub { $inst = $model->instance( root_class_name => 'Master', instance_name => 'test1' ); ok( $inst, "created dummy instance" ); $inst->initial_load_stop; $root = $inst->config_root; is( $inst->needs_save, 0, "verify instance needs_save status after creation" ); 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 olist creation" ); }; subtest "bounded list" => sub { 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" ); # each line triggers 2 changes: element creation and value storage 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'; 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" ); is( $b->fetch, 'baz,bar,toto,titi,toto,titi,toto2', "check fetch" ); $b->clear; }; subtest "model with errors" => sub { 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'; 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"; }; subtest "list with auto_created_id" => sub { 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" ); }; subtest "move, swap in bounded_list" => sub { my $b = $root->fetch_element('bounded_list'); $b->store_set( 'baz', undef, qw/bar toto titi toto titi toto2/); for ( 0 .. 4 ) { is( $b->fetch_with_id($_)->index_value, $_, "Check index value $_" ); } $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" ); for ( 0 .. 4 ) { is( $b->fetch_with_id($_)->index_value, $_, "Check moved index value $_" ); } $b->fetch_with_id(3)->store('titi'); $b->swap( 3, 4 ); for ( 0 .. 4 ) { is( $b->fetch_with_id($_)->index_value, $_, "Check swapped index value $_" ); } is( $b->fetch_with_id(3)->fetch, 'toto', "check value after swap" ); is( $b->fetch_with_id(4)->fetch, 'titi', "check value after swap" ); $inst->clear_changes; $b->remove(3); is( $b->fetch_with_id(3)->fetch, 'titi', "check after remove" ); is( scalar $inst->list_changes(), q!bounded_list: removed idx 3 ("toto")!, "check removal message"); $b->clear; }; subtest "test move swap with node list" => sub { 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" ); for ( 0 .. 4 ) { is( $ol->fetch_with_id($_)->index_value, $_, "Check moved index value $_" ); } ; $inst->clear_changes; $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" ); for ( 0 .. 4 ) { is( $ol->fetch_with_id($_)->index_value, $_, "Check moved index value $_" ); } ; 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 node gist in an array display my $olgist = $ol->fetch_with_id(5); $olgist->fetch_element('X')->store('Av'); $olgist->fetch_element('Y')->store('Bv'); is($olgist->fetch_gist,'Av and Bv', "check get_display_key"); }; subtest "load method" => sub { my $b = $root->fetch_element('bounded_list'); # 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'"; }; subtest "preset mode" => sub { $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" ); $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"); }; subtest "default_with_init on leaf" => sub { 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" ); }; foreach my $what (qw/forbid warn suppress/) { my $elt_name = 'list_with_' . $what . '_duplicates'; subtest "test $elt_name" => sub { my $lwd = $root->fetch_element( $elt_name ); $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_content_check, 1, "verify needs_content_check is true" ); throws_ok { $lwd->fetch_all_values; } "Config::Model::Exception::WrongValue", "fails forbidden duplicates"; is( $lwd->needs_content_check, 0, "verify needs_content_check after fetch_all_values" ); throws_ok { $lwd->fetch_all_values; } "Config::Model::Exception::WrongValue", "fails forbidden duplicates even if needs_content_check is false"; is( $lwd->needs_content_check, 0, "verify again needs_content_check after fetch_all_values" ); $lwd->delete(2); is( $lwd->needs_content_check, 1, "verify needs_content_check after list content modif" ); } elsif ( $what eq 'warn' ) { { my $tlog = Test::Log::Log4perl->expect([ 'User' => warn => qr/Duplicated/ ]); $lwd->fetch_all_values; } is ( $lwd->has_warning, 1, "detected duplicated values"); is( $lwd->has_fixes, 2, "check nb of fixes" ); $inst->apply_fixes; { # no warning expected my $tlog = Test::Log::Log4perl->expect([]); $lwd->fetch_all_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; subtest "preset clear stuff" => sub { my $pl = $root->fetch_element('plain_list'); # 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" ); $pl->clear; }; subtest "layered stuff" => sub { my $pl = $root->fetch_element('plain_list'); $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; }; subtest "layered stuff " => sub { # test done for https://github.com/dod38fr/config-model/issues/26#issuecomment-810572173 my $pl = $root->fetch_element('plain_list'); $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(2)->store('baz'); $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, 'baz', "check that baz was moved from 2 to 0" ); $pl->clear; }; subtest "notify change after implicit deletion (github #4)" => sub { my $pl = $root->fetch_element('plain_list'); $pl->store_set(qw/j h g f k l/); $inst->clear_changes; my @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; }; subtest "sort" => sub { my $pl = $root->fetch_element('plain_list'); my @set = qw/j h g f/; $pl->store_set(@set); $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" ); }; subtest "unshift" => sub { my $pl = $root->fetch_element('plain_list'); $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" ); }; subtest "insert_at" => sub { my $pl = $root->fetch_element('plain_list'); $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" ); }; subtest "insert_before" => sub { my $pl = $root->fetch_element('plain_list'); $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" ); }; subtest "insort" => sub { my $pl = $root->fetch_element('plain_list'); 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" ); }; subtest "load_data method" => sub { my $b = $root->fetch_element('bounded_list'); # test store my @test = ( [ a1 => ['a1'] ], [ 'a b x' => [q/a b x/] ], [ 'a b x' => [qw/a b x/], qr/ / ], [ 'a b' => [qw/a b/], qr/ / ], [ 'a,b,c' => [qw/a b c/], qr/,/ ], [ 'a,too_long,b,c' => [qw/a b c/], qr/,/ ], [ [qw/a c/] => [qw/a c/] ], ); foreach my $l (@test) { $b->load_data( data => $l->[0], split_reg => $l->[2], check => 'skip', silent => 1 ); eq_or_diff( [ $b->fetch_all_values ], $l->[1], "test store $l->[0]" ); } throws_ok { $b->load_data(plop=>'a,,b'); } "Config::Model::Exception::LoadData", "fails load_data with wrong parameter"; $b->clear; }; subtest "load_data method change tracking" => sub { my $b = $root->fetch_element('bounded_list'); $b->load_data([qw/a b c/]); $inst->clear_changes; $b->load_data([qw/a b c/]); is( $inst->needs_save, 0, "verify needs_save after loading same data" ); $b->load_data([qw/a b/]); is( $inst->needs_save, 1, "verify needs_save after loading same data" ); print scalar $inst->list_changes, "\n" if $trace; $inst->clear_changes; $b->clear; }; subtest "test load_data with node list" => sub { my $ol = $root->fetch_element('olist'); $ol->clear; $inst->clear_changes; my $load_test = sub { $ol->load_data( data => shift, check => 'skip', silent => 1 ); }; $load_test->( [ ({X=>'Av',Y=>'Bv'}) x 3]); is($ol->fetch_size,3,"check that 3 nodes was created"); # node 2 is removed because only 2 nodes are loaded $load_test->( [{X=>'Av',Y=>'Bv'},{X=>'Av',Y=>'Bv'}]); is($ol->fetch_size,2,"check that only 2 elements remain"); # node 1 is removed because all its data is bogus $load_test->( [{X=>'Av_bogus',Y=>'Bv_bogus'},{X=>'Av',Y=>'Bv'}]); is($ol->fetch_size,1,"check that only one element remains"); }; memory_cycle_ok( $model, "memory cycles" ); done_testing; Config-Model-2.149/t/cme-force-load.t0000644000175000017500000000277214170053137015654 0ustar domidomi# -*- cperl -*- use strict; use warnings; use Path::Tiny; use Test::Exception; use Test::More; use 5.10.1; use Config::Model qw/cme/; use Config::Model::Tester::Setup qw/init_test setup_test_dir/; use lib "t/lib"; my ($model, $trace) = init_test(); # pseudo root where config files are written by config-model my $wr_root = setup_test_dir(); my $etc_dir = $wr_root->child('etc'); my $conf_file = $etc_dir->child('popularity-contest.conf'); # popcon data contains an error my @orig = ; $etc_dir->mkpath; $conf_file->spew(@orig); my $instance = cme( application => 'popcon', root_dir => $wr_root, 'force-load' => 1, ); ok($instance,"new instance created"); my $root = $instance->config_root; $root->init; ok($root, "loaded erroneous data"); my $tree = $root->dump_tree(check => 'no'); say $tree if $trace; throws_ok { $root->dump_tree; } 'Config::Model::Exception::WrongValue', "barfs on bad value"; print "normal error:\n", $@, "\n" if $trace; cme('popcon')->modify("PARTICIPATE=yes"); ok( $root->dump_tree(check => 'no'), "can dump fixed tree"); $instance->save(); ok(1,"data saved"); my $new_data = $conf_file->slurp; like $new_data, qr/PARTICIPATE="yes"/, "updated config data"; done_testing; __END__ # Config file for Debian's popularity-contest package. # # To change this file, use: # dpkg-reconfigure popularity-contest ## should be removed MY_HOSTID="aaaaaaaaaaaaaaaaaaaa" # that's not a boolean value PARTICIPATE="maybe" USEHTTP="yes" # always http DAY="6" Config-Model-2.149/t/backend_multiple.t0000644000175000017500000000576314170053137016404 0ustar domidomi# -*- cperl -*- use Test::More; use Test::Memory::Cycle; use Config::Model; use File::Path; use File::Copy; use Test::Warn; use Test::Exception; use Config::Model::Tester::Setup qw/init_test setup_test_dir/; use warnings; use strict; use lib 't/lib'; my ($model, $trace) = init_test(); # pseudo root where config files are written by config-model my $wr_root = setup_test_dir( stringify => 1 ); $model->create_config_class( 'rw_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( 'rw_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( 'rw_config' => { 'auto_create' => '1', 'backend' => 'PlainFile', 'config_dir' => 'debian/source' }, 'name' => 'Test::Source', 'element' => [ 'format', { 'value_type' => 'uniline', 'type' => 'leaf', } ] ); $model->create_config_class( 'rw_config' => { auto_create => 1, auto_delete => 1, # test minimal spec with custom backend class backend => 'Mini' }, 'name' => 'Test::Meta', 'element' => [ 'email', { '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' }, meta => { type => 'node', config_class_name => 'Test::Meta' }, ] ); 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 - meta email=joe@foo.com' ); 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 meta/test.yml!) { 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, "check memory cycles"); done_testing; Config-Model-2.149/t/iterator.t0000644000175000017500000001056314170053137014725 0ustar domidomi# -*- cperl -*- use ExtUtils::testlib; use Test::More; use Test::Memory::Cycle; use Config::Model; use Config::Model::Tester::Setup qw/init_test/; use Config::Model::Value; use strict; use warnings; use lib "t/lib"; my ($model, $trace) = init_test(); my @models = $model->load( Master => 'Config/Model/models/Master.pl' ); 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; 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, "memory cycle"); done_testing; Config-Model-2.149/t/simple_ui.t0000644000175000017500000000541114170053137015056 0ustar domidomi# -*- cperl -*- use ExtUtils::testlib; use Test::More; use Test::Memory::Cycle; use Config::Model; use Config::Model::Tester::Setup qw/init_test/; use Config::Model::SimpleUI; use warnings; use strict; use lib "t/lib"; use utf8; use open qw(:std :utf8); # undeclared streams in UTF-8 use Data::Dumper; my ($model, $trace, $args) = init_test('interactive'); note("you can run the test in interactive mode by passing '--interactive' option, e.g. perl -Ilib t/simple_ui.t --interactive"); my $inst = $model->instance( root_class_name => 'Master', 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 ($args->{interactive}) { $ui->run_loop; done_testing; 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 a_boolean yes_no_boolean 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', join(' ', $root->get_element_names() ), $expected_prompt ], [ 'ls hash*', 'hash_a hash_b', $expected_prompt], [ 'll hash*', "name │ type │ value \n". "───────┼────────────┼─────────────\n". "hash_a │ value hash │ [empty hash]\n". "hash_b │ value hash │ [empty 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); is($res , $expect, "exec $cmd" ); is( $ui->prompt, $expect_prompt, "test prompt is $expect_prompt" ); } memory_cycle_ok($model, "memory cycle"); done_testing; Config-Model-2.149/t/grab.t0000644000175000017500000000670614170053137014013 0ustar domidomi# -*- cperl -*- use ExtUtils::testlib; use Test::More; use Test::Memory::Cycle; use Test::Exception; use Config::Model; use Config::Model::Tester::Setup qw/init_test/; use warnings; use strict; use lib "t/lib"; my ($model, $trace) = init_test(); my $inst = $model->instance( root_class_name => 'Master', 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:"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'; throws_ok { $root->grab( \$wp )->index_value; } qr/steps parameter must be a string or an array ref/, "Test grab with wrong parameter" ; print "normal error:\n", $@, "\n" if $trace; throws_ok { $root->grab('std_xid:toto')->index_value; } qr/unknown element 'std_xid'/, "Test grab with wrong element" ; print "normal error:\n", $@, "\n" if $trace; like( $root->grab('olist')->name, qr/olist/, 'test grab olist' ); like( $root->grab('olist')->grab->name, qr/olist/, 'test grab without argument' ); 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; 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] ); } throws_ok { $leaf->grab('?argh'); } qr/cannot grab '\?argh'from warp std_id:toto DX/, "test grab with wrong step: '?argh'" ; print "normal error:\n", $@, "\n" if $trace; throws_ok { $root->grab( step => 'std_id:zzz', autoadd => 0 ); } qr/unknown identifier 'zzz'/, "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" ); throws_ok { $root->grab( step => 'std_id:ab X', type => 'node', mode => 'strict' ); } qr/wrong element type for element/, "test strict grab with type node" ; print "normal error:\n", $@, "\n" if $trace; subtest "test grab_value" => sub { is($root->grab_value('std_id:ab X'),'Bv',"grab value"); throws_ok { my $trash = $root->grab_value('std_id:ab'); } qr/Cannot get a value from 'std_id:ab'/, "test grab_value on list item" ; }; memory_cycle_ok($model, "memory cycle"); done_testing; Config-Model-2.149/t/hash_id_of_node.t0000644000175000017500000000665214170053137016170 0ustar domidomi# -*- cperl -*- use ExtUtils::testlib; use Test::More; use Test::Memory::Cycle; use Config::Model; use Config::Model::Tester::Setup qw/init_test/; use warnings; use strict; my ($model, $trace) = init_test(); 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 $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, "memory cycle"); done_testing; Config-Model-2.149/t/search_element.t0000644000175000017500000004175414170053137016060 0ustar domidomi# -*- cperl -*- use ExtUtils::testlib; use Test::More; use Test::Memory::Cycle; use Config::Model; use Config::Model::Tester::Setup qw/init_test/; use warnings; use strict; use lib "t/lib"; use Data::Dumper; $Data::Dumper::Indent = 1; my ($model, $trace) = init_test(); 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" ); 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' => '' } }, 'yes_no_boolean' => {'next_step' => {'yes_no_boolean' => ''}}, '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' => '' } } } } } } } }, 'a_boolean' => {'next_step' => {'a_boolean' => ''}}, '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_boolean 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 yes_no_boolean/; 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, "memory cycle"); done_testing; Config-Model-2.149/t/loader_logs.t0000644000175000017500000001407014170053137015363 0ustar domidomi# -*- cperl -*- use ExtUtils::testlib; use Test::More; use Config::Model; use Config::Model::Tester::Setup qw/init_test/; use strict; use warnings; use lib "t/lib"; use Test::Log::Log4perl; my ($model, $trace) = init_test(); Test::Log::Log4perl->ignore_priority("debug"); # See caveats in Test::More doc my $builder = Test::More->builder; binmode $builder->output, ":encoding(UTF-8)"; binmode $builder->failure_output, ":encoding(UTF-8)"; binmode $builder->todo_output, ":encoding(UTF-8)"; binmode STDOUT, ':encoding(UTF-8)'; binmode STDERR, ':encoding(UTF-8)'; my $inst = $model->instance( root_class_name => 'Master', model_file => 'dump_load_model.pl', instance_name => 'test1' ); ok( $inst, "created dummy instance" ); my $root = $inst->config_root; my $t_load = Test::Log::Log4perl->get_logger("Verbose.Loader"); my $t_value = Test::Log::Log4perl->get_logger("Tree.Element.Value"); sub xlog { my ($root,$cmd, @expected) = @_; Test::Log::Log4perl->start(ignore_priority => "debug"); foreach my $exp (@expected) { if (ref($exp)) { $exp->[0]->info($exp->[1]); } else { $t_load->info($exp); } } $root->load($cmd); Test::Log::Log4perl->end("test log of '$cmd'"); } subtest "test no logs during initial_load" => sub { $root->instance->initial_load_start; xlog($root, '!'); $root->instance->initial_load_stop; }; subtest "test navigation logs" => sub { xlog($root, '!', "command '!': Going from root node to root node"); xlog( $root, 'plain_object - -', "command 'plain_object': Going down from root node to node 'plain_object'", "command '-': Going up from node 'plain_object' to root node", "command '-': Going up from root node to exit Loader." ); xlog( $root, 'ordered_hash_of_node:blah', "command 'ordered_hash_of_node:blah': Going down from root node to node 'ordered_hash_of_node:blah'", ); xlog( $root, 'olist:0', "command 'olist:0': Going down from root node to node 'olist:0'", ); }; subtest "test search logs" => sub { xlog( $root, '/plain_object', "command '/plain_object': Element 'plain_object' found in current node (root node).", "command 'plain_object': Going down from root node to node 'plain_object'", ); xlog( $root, 'olist:0 /plain_object', "command 'olist:0': Going down from root node to node 'olist:0'", "command '/plain_object': Going up from node 'olist:0' to root node to search for element 'plain_object'.", "command '/plain_object': Element 'plain_object' found in current node (root node).", "command 'plain_object': Going down from root node to node 'plain_object'", ); }; subtest "test annotation logs" => sub { xlog( $root, '#"root comment "', q!command '#"root comment "': Setting root node annotation to 'root comment '! ); xlog( $root, 'plain_object#"obj comment"', q!command 'plain_object#"obj comment"': Setting node 'plain_object' annotation to 'obj comment'!, q!command 'plain_object#"obj comment"': Going down from root node to node 'plain_object'!, ); }; subtest "test assignment logs" => sub { xlog( $root, 'a_string=blah', q!command 'a_string=blah': Setting leaf 'a_string' string to 'blah'.! ); xlog( $root, 'a_string.=blah', q!command 'a_string.=blah': Appending 'blah' to leaf 'a_string' string. Result is 'blahblah'.! ); xlog( $root, 'a_string=~s/ahbl//', q!command 'a_string=~s/ahbl//': Applying regexp 's/ahbl//' to leaf 'a_string' string. Result is 'blah'.! ); xlog( $root, 'int_v=14', q!command 'int_v=14': Setting leaf 'int_v' integer to '14'.! ); xlog( $root, 'int_v~', q!command 'int_v~': Deleting leaf 'int_v'.! ); xlog( $root, 'hash_a:foo=bar', q!command 'hash_a:foo=bar': Setting leaf 'hash_a:foo' string to 'bar'.! ); xlog( $root, 'lista:0=foo lista:1=bar', q!command 'lista:0=foo': Setting leaf 'lista:0' string to 'foo'.!, q!command 'lista:1=bar': Setting leaf 'lista:1' string to 'bar'.!, ); xlog( # change list value to avoid log like 'skip storage of lista:0 unchanged value: foo2' $root, 'lista=foo2,bar2', q!command 'lista=foo2,bar2': Setting list 'lista' values to 'foo2,bar2'.!, ); xlog( # change list value to avoid log like 'skip storage of lista:0 unchanged value: foo2' $root, 'lista:=foo3,bar3', q!command 'lista:=foo3,bar3': Setting list 'lista' values to 'foo3,bar3'.!, ); xlog( $root, 'alpha_check_list=A,C,F,G', q!command 'alpha_check_list=A,C,F,G': Setting check_list 'alpha_check_list' items 'A,C,F,G'.!, ); }; subtest "test dispatched operator" => sub { my $expect = q!Running 'push' on list 'lista' with "z", "x".!; xlog( $root, 'lista:.push(z,x)', qq!command 'lista:.push(z,x)': $expect! ); xlog( $root, 'lista:<(z,x)', qq!command 'lista:<(z,x)': $expect! ); $root->load("ordered_hash:bkey=bv ordered_hash:dkey=dv"); xlog( $root, 'ordered_hash:.insort(ckey,cv)', qq!command 'ordered_hash:.insort(ckey,cv)': Running 'insort' on hash 'ordered_hash' with "ckey", "cv".!, ) }; subtest "test creation of empty elements" => sub { xlog( $root, 'hash_a:foo', q!command 'hash_a:foo': Creating empty leaf 'hash_a:foo'.! ); }; subtest "test hash of loop" => sub { xlog( $root, 'hash_a:.clear', q!command 'hash_a:.clear': Running 'clear' on hash 'hash_a' with "".! ); $root->load("hash_a:foo1=foov1_x hash_a:foo2=foov2_x hash_a:bar=barv_x"); my $loop = 'hash_a:~/foo/=~s/_x//'; xlog( $root, $loop, map {( qq!command '$loop': Running foreach_map loop on leaf 'hash_a:foo$_'.!, qq!command '$loop': Applying regexp 's/_x//' to leaf 'hash_a:foo$_' string. Result is 'foov$_'.! )} qw/1 2/ ); }; done_testing; Config-Model-2.149/t/perlcriticrc0000644000175000017500000000073014170053137015312 0ustar domidomiseverity = 4 # remove when https://github.com/Perl-Critic/PPI/issues/194 is fixed [-Subroutines::ProhibitSubroutinePrototypes] [TestingAndDebugging::ProhibitNoWarnings] allow = experimental::postderef experimental::signatures # model files are not modules [-Modules::RequireExplicitPackage] # model files finish with a data structure: the model [-Modules::RequireEndWithOne] [RegularExpressions::RequireExtendedFormatting] minimum_regex_length_to_complain_about = 25 Config-Model-2.149/t/multi_warp_object.t0000644000175000017500000000767314170053137016615 0ustar domidomi# -*- cperl -*- use ExtUtils::testlib; use Test::More; use Test::Memory::Cycle; use Config::Model; use Config::Model::Tester::Setup qw/init_test/; use strict; use warnings; my ($model, $trace) = init_test(); # minimal set up to get things working $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', morph => 1, warp => { follow => [ '! macro1', '- macro2' ], '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, "memory cycle"); done_testing; Config-Model-2.149/t/accept.t0000644000175000017500000001077314170053137014336 0ustar domidomi# -*- cperl -*- use ExtUtils::testlib; use Test::More; use Test::Exception; 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 Test::Log::Log4perl; use Config::Model::Tester::Setup qw/init_test/; my ($model, $trace) = init_test(); $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" ); 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" ); my $i_hosts = $model->instance( instance_name => 'hosts_inst', root_class_name => 'Host', ); 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" ); is( $i_root->element_type('otary'),'leaf',"check element_type on accepted element"); is($i_root->has_element(name => 'listA', autoadd => 0), 0, "check autoadd parameter for has_element"); is($i_root->has_element(name => 'listA'), 1, "check autoadd parameter for has_element"); throws_ok { $i_root->fetch_element(name => 'listB', autoadd => 0); } "Config::Model::Exception::UnknownElement", "check autoadd parameter for fetch_element"; 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"; } my $wt = Test::Log::Log4perl->get_logger("User"); ### test always_warn parameter Test::Log::Log4perl->start(ignore_priority => "info"); my $bad = $i_root->fetch_element('badbad'); $wt->warn(qr/gotcha/); $bad->store('whatever'); Test::Log::Log4perl->end("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) { Test::Log::Log4perl->start(ignore_priority => "info"); my $expect = shift @shaves; my $msg ; if ($expect) { $wt->warn(qr/distance/); $msg = "test $close_shave too close to 'other'"; } else { $msg = "test accept $close_shave, is not too close to 'other'"; } $i_root->fetch_element($close_shave); Test::Log::Log4perl->end($msg); } } memory_cycle_ok($model, "memory cycle"); done_testing; Config-Model-2.149/t/array_with_data_migration.t0000644000175000017500000000452614170053137020311 0ustar domidomi# -*- cperl -*- use Test::More; use Test::Exception; use Test::Differences; use Test::Memory::Cycle; use Config::Model; use Config::Model::Tester::Setup qw/init_test/; use strict; use warnings; my ($model, $trace) = init_test(); # 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" ); done_testing; Config-Model-2.149/t/backend_mgr.t0000644000175000017500000001131714170053137015326 0ustar domidomi# -*- cperl -*- use Test::More; use Test::Memory::Cycle; use Test::File::Contents; use Config::Model; use List::MoreUtils qw/apply/; use Config::Model::Tester::Setup qw/init_test setup_test_dir/; use Config::Model::Role::FileHandler; use warnings; use strict; use 5.12.0; my ($model, $trace) = init_test(); # pseudo root where config files are written by config-model my $wr_root = setup_test_dir(); $model->create_config_class( 'rw_config' => { 'auto_create' => '1', 'file' => 'test.ini', 'backend' => 'ini_file', 'config_dir' => 'test' }, 'name' => 'Test', 'element' => [ 'source' => { 'type' => 'leaf', value_type => 'string', } ] ); subtest "Check reading of global comments" => sub { my $inst = $model->instance( name => "global-comment", root_class_name => 'Test', root_dir => $wr_root, ); my $root = $inst->config_root; $root->init; my @copy = my @lines = ( '## cme comment 1', '## cme comment 2', '', '# global comment1', '# global comment2', '', '# data comment', 'stuff', ); $root->backend_mgr->backend_obj->read_global_comments(\@lines, '#'); is_deeply(\@lines, [ @copy[-2,-1] ], "check untouched lines" ); is($root->annotation,join("\n", apply {s/#\s+//; $_;} @copy[3,4]), "check extracted global comment"); }; subtest "check config file with absolute path" => sub { my $abs_test_dir = $wr_root->child('abs_path_test'); $abs_test_dir->mkpath; my $ini_file = $abs_test_dir->child('test-abs.ini'); $ini_file -> spew( "source = fine"); $model->create_config_class( 'rw_config' => { 'file' => 'test-abs.ini', 'backend' => 'ini_file', 'config_dir' => $abs_test_dir->absolute->stringify.'/' }, 'name' => 'TestAbsPath', 'element' => ['source' => { 'type' => 'leaf', value_type => 'string', } ] ); my $inst = $model->instance( name => 'test-abs-path', root_class_name => 'TestAbsPath' ); my $root = $inst->config_root; $root->init; is($root->grab_value('source'),'fine', "check read data"); $root->load("source=ok"); $inst->write_back; file_contents_like( $ini_file->stringify, "source = ok","$ini_file content"); }; subtest "check config file override" => sub { my $abs_test_dir = $wr_root->child('cfg_file_override_test'); $abs_test_dir->mkpath; $model->create_config_class( 'rw_config' => { 'backend' => 'ini_file', }, 'name' => 'TestCfo', 'element' => ['source' => { 'type' => 'leaf', value_type => 'string', } ] ); my $ini_file = $abs_test_dir->child('test-cfo.ini'); # test 2 cases: relative and absolute paths my %test = ( relative => $ini_file, absolute => $ini_file->absolute, ); while ( my ($label, $cfg_file) = each %test) { $cfg_file -> spew( "source = fine"); my $inst = $model->instance( name => "test-cfo-$label", root_class_name => 'TestCfo', config_file => $cfg_file->stringify ); my $root = $inst->config_root; $root->init; is($root->grab_value('source'),'fine', "check read data ($label path)"); $root->load("source=ok"); $inst->write_back; file_contents_like( $ini_file->stringify, "source = ok","$ini_file content ($label path)"); } }; subtest "check string to Path::Tiny coercion" => sub { Config::Model::Role::FileHandler::_set_test_home('/home/joe'); my $test_root_dir = $wr_root->child('coercion_test'); my $joe_conf_dir = $test_root_dir->child('home/joe/conf'); $joe_conf_dir->mkpath; my $ini_file = $joe_conf_dir->child('test-coercion.ini'); $ini_file -> spew( "source = fine"); $model->create_config_class( 'name' => 'TestCoercion', 'rw_config' => { 'backend' => 'ini_file', file => 'test-coercion.ini', }, 'element' => ['source' => { 'type' => 'leaf', value_type => 'string', } ] ); my $inst = $model->instance( name => 'test-coercion', root_class_name => 'TestCoercion', root_dir => $test_root_dir->stringify, 'config_dir' => '~/conf/', ); my $root = $inst->config_root; $root->init; is($root->grab_value('source'),'fine', "check read data"); $root->load("source=ok"); $inst->write_back; is($root->backend_mgr->config_dir,'/home/joe/conf',"check that ~ is coerced into /home/joe"); file_contents_like( $ini_file->stringify, "source = ok","$ini_file content"); }; memory_cycle_ok($model, "memory cycle"); done_testing; Config-Model-2.149/t/lib/0000755000175000017500000000000014170053137013450 5ustar domidomiConfig-Model-2.149/t/lib/DummyNode.pm0000644000175000017500000000051514170053137015710 0ustar domidomi# # This file is part of Config-Model # # This software is Copyright (c) 2005-2022 by Dominique Dumont. # # This is free software, licensed under: # # The GNU Lesser General Public License, Version 2.1, February 1999 # package DummyNode; use strict; use warnings; use base qw/Config::Model::Node/; sub dummy { $_[1]++; } 1; Config-Model-2.149/t/lib/test_ini_backend_model.pl0000644000175000017500000001332014170053137020451 0ustar domidomi# # This file is part of Config-Model # # This software is Copyright (c) 2005-2022 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 use strict; use warnings; return [ { rw_config => { backend => 'IniFile', config_dir => '/etc/', file => 'test.ini', auto_create => 1, auto_delete => 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' } ] }, { rw_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 => 'IniTest3', rw_config => { backend => 'IniFile', config_dir => '/etc/', file => 'test.ini', auto_create => 1, comment_delimiter => '#;', }, 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', rw_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' }, }, ], rw_config => { backend => 'IniFile', config_dir => '/etc/', file => 'test.ini', store_class_in_hash => 'any_ini_class', auto_create => 1, }, }, { name => 'IniCheck', rw_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/], }, ] }, { name => 'IniDQuotes', rw_config => { backend => 'IniFile', file => 'test.ini', auto_create => 1, quote_value => 'shell_style', }, element => [ baz => { qw/type leaf value_type string/, }, a_list => { type => 'list', cargo => { type => 'leaf', value_type => 'uniline', } }, ] }, ]; Config-Model-2.149/t/lib/dump_load_model.pl0000644000175000017500000002016714170053137017137 0ustar domidomi# -*- cperl -*- # # This file is part of Config-Model # # This software is Copyright (c) 2005-2022 by Dominique Dumont. # # This is free software, licensed under: # # The GNU Lesser General Public License, Version 2.1, February 1999 # use strict; use warnings; # this file is used by test script return [ [ 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', config_class_name => 'SubSlave', morph => 1, warp => { follow => '! tree_macro', 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', value_type => 'string' }, }, [qw/hash_a hash_b/] => { type => 'hash', index_type => 'string', cargo => { type => 'leaf', value_type => 'string' }, summary => "hash_* summary", }, ordered_hash => { type => 'hash', index_type => 'string', ordered => 1, cargo => { type => 'leaf', value_type => 'string' }, }, ordered_hash_of_node => { type => 'hash', index_type => 'string', ordered => 1, cargo => { type => 'node', config_class_name => 'SubSlave2', } }, olist => { type => 'list', cargo => { type => 'node', config_class_name => 'SlaveZ' }, }, bool_list => { type => 'list', cargo => { type => 'leaf', value_type => 'boolean' } }, int_list_with_max => { type => 'list', cargo => { type => 'leaf', value_type => 'integer', max => 10, } }, 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', config_class_name => 'SlaveY', morph => 1, warp => { follow => '! tree_macro', 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 }, alpha_check_list => { type => 'check_list', choice => ['A' .. 'Z'], }, 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 Config-Model-2.149/t/lib/load-data.json0000644000175000017500000000013214170053137016165 0ustar domidomi{ "foo": { "bar": "bar json value" }, "foo_array": [ "bar", "baz" ] } Config-Model-2.149/t/lib/Config/0000755000175000017500000000000014170053137014655 5ustar domidomiConfig-Model-2.149/t/lib/Config/Model/0000755000175000017500000000000014170053137015715 5ustar domidomiConfig-Model-2.149/t/lib/Config/Model/Backend/0000755000175000017500000000000014170053137017244 5ustar domidomiConfig-Model-2.149/t/lib/Config/Model/Backend/Mini.pm0000644000175000017500000000363014170053137020500 0ustar domidomi# # This file is part of Config-Model # # This software is Copyright (c) 2005-2022 by Dominique Dumont. # # This is free software, licensed under: # # The GNU Lesser General Public License, Version 2.1, February 1999 # package Config::Model::Backend::Mini ; use strict; use warnings; use 5.10.1; use Mouse; extends 'Config::Model::Backend::Any'; with 'Config::Model::Role::FileHandler'; use Path::Tiny; use YAML::Tiny qw/LoadFile Dump/; sub _get_cfg_dir { my ($self,$root) = @_; my $dir = $self->get_tuned_config_dir( config_dir => 'debian/meta', root => $root ); my $file = $dir->child('test.yml'); return $file; } sub read { my $self = shift; my %args = @_; # args is: # object => $obj, # Config::Model::Node object # root => './my_test', # fake root directory, userd for tests # config_dir => /etc/foo', # absolute path # file => 'foo.conf', # file name # file_path => './my_test/etc/foo/foo.conf' # check => yes|no|skip my $file = $self->_get_cfg_dir($args{root}); return 0 unless $file->exists; # no file to read my $perl_data = LoadFile($file); # 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, used for tests # config_dir => /etc/foo', # absolute path # file => 'foo.conf', # file name # file_path => './my_test/etc/foo/foo.conf' # check => yes|no|skip my $perl_data = $self->node->dump_as_data( full_dump => $args{full_dump} // 0); my $file = $self->_get_cfg_dir($args{root}); $file->parent->mkpath; my $yaml = Dump( $perl_data ); $file->spew_utf8($yaml); return 1; } 1; Config-Model-2.149/t/lib/Config/Model/models/0000755000175000017500000000000014170053137017200 5ustar domidomiConfig-Model-2.149/t/lib/Config/Model/models/Master.pl0000644000175000017500000001635614170053137021003 0ustar domidomi# -*- cperl -*- # # This file is part of Config-Model # # This software is Copyright (c) 2005-2022 by Dominique Dumont. # # This is free software, licensed under: # # The GNU Lesser General Public License, Version 2.1, February 1999 # use strict; use warnings; # this file is used by test script return [ [ 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', config_class_name => 'SubSlave', morph => 1, warp => { follow => '! tree_macro', 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', value_type => 'string' }, }, [qw/hash_a hash_b/] => { type => 'hash', index_type => 'string', cargo => { type => 'leaf', value_type => 'string' }, }, ordered_hash => { type => 'hash', index_type => 'string', ordered => 1, cargo => { type => 'leaf', 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', config_class_name => 'SlaveY', morph => 1, warp => { follow => '! tree_macro', 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', }, a_boolean => { type => 'leaf', value_type => 'boolean', }, yes_no_boolean => { type => 'leaf', value_type => 'boolean', upstream_default => 'yes', write_as => [ 'no', 'yes' ], }, 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 Config-Model-2.149/t/lib/load-data.yaml0000644000175000017500000000004114170053137016155 0ustar domidomi--- foo: bar: "bar yaml value" Config-Model-2.149/t/value_refer_to.t0000644000175000017500000001516614170053137016101 0ustar domidomi# -*- cperl -*- use ExtUtils::testlib; use Test::More ; use Test::Memory::Cycle; use Test::Log::Log4perl; use Test::Exception; use Config::Model; use Config::Model::Tester::Setup qw/init_test/; use strict; use warnings; Test::Log::Log4perl->ignore_priority("info"); my ($model, $trace) = init_test(); $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', computed_refer_to => { formula => ' ! host:$h if ', variables => { h => '- host' } } }, ip => { type => 'leaf', value_type => 'string', compute => { formula => '$ip', variables => { 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', 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" ; { # store unknown host (skip mode) my $xp = Test::Log::Log4perl->expect( ['User', warn => qr/skipping value/] ); $root->fetch_element("host_reference")->store(value => 'Foo', check => 'skip') } 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; Config-Model-2.149/t/backend_ini.t0000644000175000017500000002041214170053137015314 0ustar domidomi# -*- cperl -*- # NOTE: backend can also be tested in model_test.d #use ExtUtils::testlib; use Test::More; use Test::File::Contents; use Test::Memory::Cycle; use Config::Model; use Config::Model::Tester::Setup qw/init_test setup_test_dir/; use warnings; use strict; use lib "t/lib"; my ($model, $trace) = init_test(); # pseudo root where config files are written by config-model my $wr_root = setup_test_dir(); # set_up data my @with_semicolon_comment = my @with_one_semicolon_comment = my @with_hash_comment = ; # change delimiter comments for (@with_semicolon_comment) { s/#/;/; } ; for (@with_one_semicolon_comment) { s/# foo2/; foo2/; } ; # models are stored in t/lib/test_ini_backend_model.pl sub init_backend_test { my ($test_class, $test_data, $instance_name, $config_dir) = @_; my @orig = @$test_data ; ok( 1, "Starting $test_class tests" ); my $test1 = 'ini1'; my $wr_dir = $wr_root->child($test1); my $etc_dir = $wr_dir->child('etc'); $etc_dir->mkpath; my $conf_file = $etc_dir->child("test.ini"); $conf_file->remove; $conf_file->spew_utf8(@orig) if @orig; my $i_test = $model->instance( instance_name => $instance_name, root_class_name => $test_class, root_dir => $wr_dir, model_file => '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, $conf_file); } sub finish { my ($test_class, $instance_name, $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->child('etc/test.ini'); ok( $ini_file->exists, "check that config file $ini_file was written" ); # create another instance to read the IniFile that was just written my $wr_dir2 = $wr_root->child('ini2'); my $etc2 = $wr_dir2->child('etc'); $etc2->mkpath; my $conf_file2 = $etc2->child('test.ini'); note "copying $ini_file in $conf_file2"; $ini_file->copy( $conf_file2 ); my $i2_test = $model->instance( instance_name => $instance_name, 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" ); return ($ini_file,$conf_file2); } my %test_setup = ( IniTest => [ \@with_hash_comment, 'class1' ], IniTest2 => [ \@with_semicolon_comment, 'class1' ], IniTest3 => [ \@with_one_semicolon_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_backend_test($test_class, $test_setup{$test_class}[0], "test_inst_for_$test_class"); 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, "test_inst2_for_$test_class", $wr_dir, $model,$i_test); } subtest "test ini file using a check list" => sub { # IniCheck my ($model, $i_test, $wr_dir) = init_backend_test(IniCheck => \@with_hash_comment, "test_inst_for_check_list", '/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', "test_inst2_for_check_list", $wr_dir, $model,$i_test); }; # test start with no ini file and should not write any after subtest "Test with empty ini file and no ini data" => sub { $wr_root->remove_tree; my ($model, $i_test, $wr_dir, $conf_file) = init_backend_test(IniTest => [], "test_inst_for_no_data", '/etc/'); my $i_root = $i_test->config_root; # load some data so change notif is triggered $i_root->load("baz=blork"); my $orig = $i_test->config_root->dump_tree; print $orig if $trace; # delete data and go back to default values, hence the # configuration no longer contains valid data $i_root->load("baz~"); print $i_test->config_root->dump_tree if $trace; $i_test->write_back; ok( 1, "Empty IniFile write back done" ); isnt($conf_file->exists, 1, "no file was written"); }; # test start with small ini file, delete all data so no file should be # left subtest "Test with small ini file and delete data" => sub { $wr_root->remove_tree; my ($model, $i_test, $wr_dir, $conf_file) = init_backend_test( IniTest => ["\n","baz = blork\n"], "test_inst_for_one_data", '/etc/' ); is($conf_file->exists, 1, "ini file was written"); my $i_root = $i_test->config_root; is($i_root->grab_value("baz"), 'blork', "check load of small data"); my $orig = $i_test->config_root->dump_tree; print $orig if $trace; # delete data and go back to default values, hence the # configuration no longer contains valid data $i_root->load("baz~"); print $i_test->config_root->dump_tree if $trace; $i_test->write_back; ok( 1, "Empty IniFile write back done" ); isnt($conf_file->exists, 1, "file is gone"); }; subtest "Test handling of double quote" => sub { $wr_root->remove_tree; my $test_class = "IniDQuotes"; # TODO: test also quotes in hash/list like values my ($model, $i_test, $wr_dir, $conf_file) = init_backend_test( $test_class => [ q!baz = "blork "glop" blork"!."\n", q!a_list = "blork blork"!."\n", q!a_list = "glop glop"!."\n", ], "test_double_quotes", '/etc/' ); is($conf_file->exists, 1, "ini file was written"); my $i_root = $i_test->config_root; is($i_root->grab_value("baz"), qq!blork glop blork!, "check load of small data"); is($i_root->grab_value("a_list:0"), qq!blork blork!, "check load of list 0"); is($i_root->grab_value("a_list:1"), qq!glop glop!, "check load of list 1"); my $orig = $i_test->config_root->dump_tree; print $orig if $trace; $i_test->write_back(force => 1); foreach my $item ( qq!baz = "blork glop blork"!, q!a_list = "blork blork"!, q!a_list = "glop glop"! ) { file_contents_like( $conf_file->stringify, $item, "check content of written file $conf_file with «$item»" ); } }; 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 Config-Model-2.149/t/backend_plainfile.t0000644000175000017500000000416114170053137016503 0ustar domidomi# -*- 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 Config::Model::Tester::Setup qw/init_test setup_test_dir/; use warnings; use strict; my ($model, $trace) = init_test(); # pseudo root where config files are written by config-model my $wr_root = setup_test_dir( stringify => 0 ); my $subdir = $wr_root->child('plain'); $subdir->mkpath; $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/} }, ], rw_config => { backend => 'plain_file', config_dir => $subdir->relative($wr_root), }, ); $subdir->child('source')->spew("2.0\n"); ok( 1, "wrote source file" ); $subdir->child('clean')->spew("foo\n*/*/bar\n"); 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->child('plain/new'); ok($new_file->is_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 file 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; Config-Model-2.149/t/augment_class.t0000644000175000017500000000755214170053137015725 0ustar domidomi# -*- cperl -*- use Test::More; use Test::Memory::Cycle; use Test::Differences; use Config::Model; use Data::Dumper; use Config::Model::Tester::Setup qw/init_test/; use strict; use warnings; my ($model, $trace) = init_test(); $model->create_config_class( name => "Master", accept => [ '.*' => { type => 'leaf', value_type => 'uniline', } ], element => [ one => { type => 'leaf', value_type => 'string', }, override_vtype => { type => 'leaf', value_type => 'uniline', }, fs_vfstype => { type => 'leaf', value_type => 'enum', choice => [qw/auto ext2 ext3/], }, fs_mntopts => { type => 'warped_node', warp => { 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 => [ override_vtype => { type => 'leaf', value_type => 'integer', min => 1, }, three => { type => 'leaf', value_type => 'string', }, fs_vfstype => { choice => [qw/ext4/], }, fs_mntopts => { warp => { 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_clone('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 override_vtype 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}{warp}{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" ); is( $augmented_model->{element}{override_vtype}{value_type}, 'integer', "test value type override" ); is( $augmented_model->{element}{override_vtype}{min}, 1, "test min setup" ); eq_or_diff( $augmented_model->{accept_list}, [ '.*', 'ip.*' ], "test accept_list" ); is( $augmented_model->{accept}{'.*'}{description}, 'catchall', "test augmented rules" ); memory_cycle_ok($model,"check memory cycles"); done_testing; Config-Model-2.149/t/model_tests.t0000644000175000017500000000016314170053137015411 0ustar domidomi# -*- cperl -*- use warnings; use strict; use Config::Model::Tester 4.002; use ExtUtils::testlib; run_tests(); Config-Model-2.149/t/load_model_snippets.t0000644000175000017500000000755314170053137017125 0ustar domidomi# -*- cperl -*- use ExtUtils::testlib; use Test::More; use Test::Exception; use Test::Memory::Cycle; use Test::Differences; use Data::Dumper; use Config::Model; use Config::Model::Tester::Setup qw/init_test setup_test_dir/; use strict; use warnings; use lib 'wr_root/load_model_snippets'; my ($model, $trace) = init_test(); # pseudo root where config files are written by config-model my $wr_root = setup_test_dir(); my $model_dir = $wr_root->child('Config/Model/models'); $model_dir->mkpath; 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', warp => { 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 $model_dir->child('Master.pl')->spew($str); $str = << 'EOF' ; [{ name => "Two", element => [ two => { type => 'leaf', value_type => 'string', }, ] }] ; EOF $model_dir->child('Two.pl')->spew($str); $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 => { warp => { rules => [ q!$f1 eq 'ext4'!, { 'config_class_name' => 'Fstab::Ext4FsOpt' }, ] }, }, ] }; EOF my $snippet_dir = $model_dir->child('Master.d'); $snippet_dir->mkpath(); $snippet_dir->child('Three.pl')->spew($str); # 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_clone('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}{warp}{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); done_testing; Config-Model-2.149/t/check_list_warp.t0000644000175000017500000000415114170053137016231 0ustar domidomi# -*- 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 Config::Model::Tester::Setup qw/init_test/; my ($model, $trace) = init_test(); 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, warp => { 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, "memory cycle"); done_testing; Config-Model-2.149/t/node-load.t0000644000175000017500000000462514170053137014740 0ustar domidomi# -*- cperl -*- use ExtUtils::testlib; use Test::More; use Test::Memory::Cycle; use Config::Model; use Config::Model::Tester::Setup qw/init_test/; use 5.010; use warnings; use strict; use lib 't/lib'; my ($model, $trace) = init_test(); 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', warp => { 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"); done_testing; Config-Model-2.149/t/instance-reset.t0000644000175000017500000000337514170053137016023 0ustar domidomi use warnings; use strict; use Test::More; use Test::Memory::Cycle; use Config::Model; use Config::Model::Tester::Setup qw/init_test setup_test_dir/; use lib "t/lib"; sub check { my ($node, $msg) = @_; is($node->grab_value('foo:0'),'foo1',"$msg: foo:0 is set"); is($node->grab_value('class1 lista:0'),'lista1',"$msg: lista:0 is set"); is($node->grab_value('class1 listb:0'),undef,"$msg: listb:0 is not set"); is($node->instance->needs_save,0, "$msg: instance has no data to save"); } my ($model, $trace) = init_test(); # pseudo root where config files are written by config-model my $wr_root = setup_test_dir(); # set_up data my @ini_data = ; my $test1 = 'ini1'; my $wr_dir = $wr_root->child($test1); my $etc_dir = $wr_dir->child('etc'); $etc_dir->mkpath; my $conf_file = $etc_dir->child("test.ini"); $conf_file->remove; $conf_file->spew_utf8(@ini_data); my $i_test = $model->instance( instance_name => 'to_reset', root_class_name => 'IniTest', root_dir => $wr_dir, model_file => 'test_ini_backend_model.pl', ); ok( $i_test, "Created instance" ); my $i_root = $i_test->config_root; ok( $i_root, "created tree root" ); $i_root->init; ok( 1, "root init done" ); check($i_root, "before reset"); my $dump = $i_root->dump_tree; print "Before reset:\n",$dump if $trace; $i_root->load("foo:=blork1 class1 listb:=blork"); ok($i_root->needs_save, "instance has something to save"); my $new_root = $i_test->reset_config; ok(1, "config was reset"); check($new_root, "after reset"); is($new_root->dump_tree, $dump, "check dump tree after reset"); ok($i_root->needs_save, "instance has something to save"); memory_cycle_ok( $model, "memory cycle test" ); done_testing; __DATA__ foo = foo1 [class1] lista=lista1 Config-Model-2.149/t/value_simple_warp.t0000644000175000017500000001454114170053137016612 0ustar domidomi# -*- cperl -*- use warnings; use strict; use ExtUtils::testlib; use Test::More; use Test::Memory::Cycle; use Config::Model; use Data::Dumper; use Test::Log::Log4perl; use Config::Model::Tester::Setup qw/init_test setup_test_dir/; Test::Log::Log4perl->ignore_priority("info"); my ($model, $trace) = init_test(); 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/] ); $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 }, }, 'Standards-Version' => { 'default' => '4.1.0', 'type' => 'leaf', 'value_type' => 'uniline', 'warn_unless' => { 'current' => { 'code' => '$_ eq $self->_fetch_std;', 'fix' => '$_ = undef; # restore default value', 'msg' => q!Current standards version is '$std_value'! } } }, Priority => { 'choice' => ['required', 'important', 'standard', 'optional', 'extra'], 'default' => 'optional', 'type' => 'leaf', 'value_type' => 'enum', 'warp' => { 'follow' => { 'std_ver' => '- Standards-Version' }, 'rules' => [ q!$std_ver ge '4.0.1'! => {'replace' => {'extra' => 'optional'}} ] } }, ], # 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 $tlogger = Test::Log::Log4perl->get_logger("User"); 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" ); my $stdv = $root->fetch_element('Standards-Version'); my $prio = $root->fetch_element('Priority'); my $store_with_log_test = sub { my $v = shift; Test::Log::Log4perl->start(ignore_priority => 'info'); $tlogger->warn(qr/Current standards version/); $stdv->store($v); Test::Log::Log4perl->end("Test that store('$v') logs okay"); }; $store_with_log_test->('3.9.8'); $prio->store('extra'); is($prio->fetch, 'extra', "check value with old std_version"); $stdv->apply_fixes; is($prio->fetch, 'optional', "check value with new std_version"); is($stdv->fetch, '4.1.0', "check std_v default value"); $store_with_log_test->('3.9.8'); $prio->store('extra'); is($prio->fetch, 'extra', "check value with old std_version (2)"); $store_with_log_test->('4.0.2'); is($prio->fetch, 'optional', "check value with new std_version (2)"); $stdv->apply_fixes; is($prio->fetch, 'optional', "check value with new std_version (2)"); memory_cycle_ok($model, "check memory cycles"); done_testing; Config-Model-2.149/t/search_in_tree.t0000644000175000017500000000301014170053137016033 0ustar domidomi# -*- cperl -*- use ExtUtils::testlib; use Test::More; use Test::Differences; use Test::Memory::Cycle; use Config::Model; use Config::Model::Tester::Setup qw/init_test/; use warnings; use strict; use lib "t/lib"; my ($model, $trace) = init_test(); 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 $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, "memory cycle"); done_testing; Config-Model-2.149/t/dump_tree.t0000644000175000017500000001717614170053137015067 0ustar domidomi# -*- cperl -*- use ExtUtils::testlib; use Test::More; use Test::Memory::Cycle; use Test::Differences; use Config::Model; use Config::Model::Tester::Setup qw/init_test/; use warnings; use strict; use lib "t/lib"; my ($model, $trace) = init_test(); my $inst = $model->instance( root_class_name => 'Master', model_file => 'dump_load_model.pl', 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 hash_b:comment_test="#"' . ' hash_a:"~"="~/bar" '; 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; subtest "test round trip" => sub { my $load_inst = $model->instance( root_class_name => 'Master', model_file => 'dump_load_model.pl', instance_name => 'round_trip' ); my $round_root = $load_inst->config_root; ok($round_root->load($cds), "test round trip: load"); my $new_cds = $round_root->dump_tree; eq_or_diff( [ split /\n/, $new_cds ], [ split /\n/, $cds ], "test round trip: dump " ) }; 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_a:"~"="~/bar" hash_b:X3=xy hash_b:comment_test="#" 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( mode => 'user' ); 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_a:"~"="~/bar" hash_b:X3=xy hash_b:comment_test="#" 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( mode => 'user' ); 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_a:"~"="~/bar" hash_b:X3=xy hash_b:comment_test="#" 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_a:"~"="~/bar" hash_b:X3=xy hash_b:comment_test="#" 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( mode => 'user' ); 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'); for ( qw/XY XZ mXY XY mXY XZ/ ) { $tm->store($_); } $cds = $root->dump_tree( mode => 'user', 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 for ( 0 .. 3 ) { $listb->fetch_with_id($_)->store(undef) } $cds = $root->dump_tree( mode => 'user' ); 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( mode => 'user' ); 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( mode => 'user' ); print "Dump second instance with annotations:\n$cds2" if $trace; is( $cds2, $cds, "check both dumps" ); memory_cycle_ok( $model, "memory cycles" ); done_testing; Config-Model-2.149/t/log-init.t0000644000175000017500000000145314170053137014614 0ustar domidomi# -*- cperl -*- use strict; use warnings; use Path::Tiny; use Test::More; use Config::Model qw/initialize_log4perl/; my %specs = ( 'single class' => 'Loader', 'multiple classes' => [ 'Loader', 'Thingy' ], ); Config::Model::force_usage_of_default_log_config(); foreach my $test (sort keys %specs) { subtest "$test log init" => sub { my $arg = $specs{$test}; my $res = initialize_log4perl( verbose => $arg ); ok ($res, "$test init called" ); my @classes = ref $arg ? @$arg: ($arg) ; foreach my $c (@classes) { is($res->{"log4perl.logger.Verbose.$c"}, "INFO, PlainMsgOnScreen", "check changed setting"); } is($res->{"log4perl.appender.Screen"}, "Log::Log4perl::Appender::Screen", "check default setting"); }; } done_testing; Config-Model-2.149/t/backend_ini_with_section_map.t0000644000175000017500000001456514170053137020744 0ustar domidomi# -*- cperl -*- # NOTE: backend can also be tested in model_test.d 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_p/backend-ini-section-map'; 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', 'rw_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', 'rw_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 => oct(755) } ) || die "can't mkpath: $!"; open my $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 => oct(755) } ) || 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; Config-Model-2.149/t/include.t0000644000175000017500000000456514170053137014524 0ustar domidomi# -*- cperl -*- use ExtUtils::testlib; use Test::More; use Test::Exception; use Test::Differences; use Test::Memory::Cycle; use Config::Model; use Config::Model::Tester::Setup qw/init_test/; use strict; use warnings; # minimal set up to get things working my ($model, $trace) = init_test(); $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_clone('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 $rw_config = { 'auto_create' => 1, 'backend' => 'Xorg', 'config_dir' => '/etc/X11', 'file' => 'xorg.conf' }; $model->create_config_class( 'name' => 'Xorg::ConfigDir', 'rw_config' => $rw_config ); my $xorg_model = $model->get_model_clone('LikeXorg'); eq_or_diff($xorg_model->{rw_config}, $rw_config,"check included read specification"); memory_cycle_ok($model, "memory cycles"); done_testing; Config-Model-2.149/t/warped_value.t0000644000175000017500000004723714170053137015562 0ustar domidomi# -*- cperl -*- use Test::More; use Test::Differences; use Test::Memory::Cycle; use Test::Exception; use Config::Model; use Config::Model::ValueComputer; use Config::Model::Tester::Setup qw/init_test/; use strict; use warnings; my ($model, $trace) = init_test(); $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' }, # a bit dumb, but required to test warp from computed value 'compute_simple' => { type => 'leaf', value_type => 'string', compute => { formula => 'my element is &element', }, }, warped_from_computed_value => { type => 'leaf', value_type => 'string', level => 'hidden', default => 'hello', warp => { follow => { c => '- compute_simple' }, rules => [ '$c =~ /simple/' => { level => 'normal', }, ] } } ] ); 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 compute_simple warped_from_computed_value' ], "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 compute_simple warped_from_computed_value' ], "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 compute_simple warped_from_computed_value' ], "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" ); foreach (qw/X Y Z/) { is( $slave->fetch_element($_)->fetch, 'Av', "reading slave->$_ (Av)" ); } 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('warped_from_computed_value')->fetch, 'hello', "check 'warped_from_computed_value"); 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" ); foreach (qw/X Y Z/) { is( $slave->fetch_element($_)->fetch, 'Bv', "reading slave->$_ (Bv)" ); } 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'); foreach (qw/X Z/) { is( $slave->fetch_element($_)->fetch, undef, "reading slave->$_ (undef)" ); } 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 ; Config-Model-2.149/contrib/0000755000175000017500000000000014170053137014077 5ustar domidomiConfig-Model-2.149/contrib/log4config-model0000644000175000017500000000522414170053137017156 0ustar domidomi# 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 Config-Model-2.149/contrib/bash_completion.cme_multistrap0000644000175000017500000000054214170053137022220 0ustar domidomi# 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 ) ) } Config-Model-2.149/build-from-git.md0000644000175000017500000000326014170053137015603 0ustar domidomi# How to build Config::Model from git repository `Config::Model` is build with [Dist::Zilla](http://dzil.org/). This pages details how to install the tools and dependencies required to build this module. ## Install tools and dependencies ### Debian, Ubuntu and derivatives Run $ sudo apt install libdist-zilla-perl libdist-zilla-app-command-authordebs-perl $ dzil authordebs --install $ sudo apt build-dep libconfig-model-perl The [libdist-zilla-app-command-authordebs-perl package](https://tracker.debian.org/pkg/libdist-zilla-app-command-authordebs-perl) is quite recent (uploaded on Dec 2016 in Debian/unstable) and may not be available yet on your favorite distribution. ### Other systems Run $ cpamn Dist::Zilla $ dzil authordeps -missing | cpanm --notest $ cpanm --quiet --notest --skip-satisfied MouseX::NativeTraits $ dzil listdeps --missing | cpanm --notest NB: The author would welcome pull requests that explains how to install these tools and dependencies using native package of other distributions. ## Build Config::Model Run dzil build or dzil test `dzil` may complain about missing `EmailNotify` or `Twitter` plugin. You may ignore this or edit [dist.ini](dist.ini) to comment out the last 2 sections. These are useful only to the author when releasing a new version. `dzil` may also return an error like `Cannot determine local time zone`. In this case, you should specify explicitely your timezone in a `TZ` environement variable. E.g run `dzil` this way: TZ="Europe/Paris" dzil test The list of possible timezones is provided by [DateTime::TimeZone::Catalog](https://metacpan.org/pod/DateTime::TimeZone::Catalog) documentation. Config-Model-2.149/MODELS0000644000175000017500000000102714170053137013345 0ustar domidomiThis 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 Config-Model-2.149/MANIFEST0000644000175000017500000001365014170053137013575 0ustar domidomi# This file was automatically generated by Dist::Zilla::Plugin::Manifest v6.024. Build.PL CONTRIBUTING.md Changes LICENSE MANIFEST MANIFEST.SKIP META.json META.yml MODELS README.install.pod README.md SIGNATURE TODO build-from-git.md contrib/bash_completion.cme_multistrap contrib/log4config-model 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/CdsFile.pm lib/Config/Model/Backend/Fstab.pm lib/Config/Model/Backend/IniFile.pm lib/Config/Model/Backend/Json.pm lib/Config/Model/Backend/PerlFile.pm lib/Config/Model/Backend/PlainFile.pm lib/Config/Model/Backend/ShellVar.pm lib/Config/Model/BackendMgr.pm lib/Config/Model/BackendTrackOrder.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/ComputeFunction.pm lib/Config/Model/Role/Constants.pm lib/Config/Model/Role/FileHandler.pm lib/Config/Model/Role/Grab.pm lib/Config/Model/Role/HelpAsText.pm lib/Config/Model/Role/NodeLoader.pm lib/Config/Model/Role/Utils.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/TypeConstraints.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/log4perl.conf 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/README.md 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/author-critic.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/check_list.t t/check_list_warp.t t/cme-force-load.t t/cme-function.t t/describe_node.t t/dump_as_data.t t/dump_tree.t t/fuse_ui.t t/gen-class-doc.t t/get_info.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-reset.t t/instance.t t/iterator.t t/lib/Config/Model/Backend/Mini.pm t/lib/Config/Model/models/Master.pl t/lib/DummyNode.pm t/lib/dump_load_model.pl t/lib/load-data.json t/lib/load-data.yaml t/lib/test_ini_backend_model.pl t/load-model.t t/load.t t/load_model_snippets.t t/loader_logs.t t/log-init.t t/model.t t/model_tests.d/backend-cds-examples/basic t/model_tests.d/backend-cds-test-conf.pl t/model_tests.d/backend-ini-examples/complex t/model_tests.d/backend-ini-test-conf.pl t/model_tests.d/backend-json-examples/basic t/model_tests.d/backend-json-test-conf.pl t/model_tests.d/backend-key-value-examples/bts-control t/model_tests.d/backend-key-value-test-conf.pl t/model_tests.d/backend-perl-examples/basic t/model_tests.d/backend-perl-test-conf.pl t/model_tests.d/backend-plainfile-examples/with-index/debian/bar.install.list t/model_tests.d/backend-plainfile-examples/with-index/debian/bar.move.list t/model_tests.d/backend-plainfile-examples/with-index/debian/foo.install.list t/model_tests.d/backend-plainfile-test-conf.pl t/model_tests.d/backend-shellvar-examples/debian-719256 t/model_tests.d/backend-shellvar-examples/keep-order 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/multi-ini-examples/max-overflow/etc/bar.conf t/model_tests.d/multi-ini-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/perl-critic.t t/perlcriticrc 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/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 weaver.ini Config-Model-2.149/LICENSE0000644000175000017500000006013214170053137013446 0ustar domidomiThis software is Copyright (c) 2005-2022 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 Config-Model-2.149/META.yml0000644000175000017500000000365214170053137013716 0ustar domidomi--- abstract: 'a framework to validate, migrate and edit configuration files' author: - 'Dominique Dumont' build_requires: Config::Model::Tester: '4.002' Config::Model::Tester::Setup: '0' File::Copy: '0' File::Spec: '0' IO::File: '0' Module::Build: '0.34' Test::Differences: '0' Test::Exception: '0' Test::File::Contents: '0' Test::Log::Log4perl: '0' Test::Memory::Cycle: '0' Test::More: '0' Test::Perl::Critic: '0' Test::Pod: '1.00' Test::Warn: '0.11' boolean: '0' lib: '0' configure_requires: Module::Build: '0.34' dynamic_config: 0 generated_by: 'Dist::Zilla version 6.024, CPAN::Meta::Converter version 2.150010' license: lgpl meta-spec: url: http://module-build.sourceforge.net/META-spec-v1.4.html version: '1.4' name: Config-Model recommends: Fuse: '0' Term::ReadLine: '0' Text::Levenshtein::Damerau: '0' requires: Carp: '0' Carp::Assert::More: '0' Cwd: '0' Data::Dumper: '0' Encode: '0' English: '0' Fcntl: '0' File::HomeDir: '0' File::Path: '0' Hash::Merge: '0.12' JSON: '0' List::MoreUtils: '0' List::Util: '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.070' Pod::POM: '0' Pod::Simple: '3.23' Pod::Text: '0' Regexp::Common: '0' Scalar::Util: '0' Storable: '0' Text::Levenshtein::Damerau: '0' Text::Wrap: '0' YAML::Tiny: '0' base: '0' feature: '0' open: '0' overload: '0' parent: '0' perl: v5.20.0 strict: '0' utf8: '0' vars: '0' warnings: '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.149' x_generated_by_perl: v5.32.1 x_serialization_backend: 'YAML::Tiny version 1.73' x_spdx_expression: LGPL-2.1

For more information, see this blog.