Config-Model-2.097/0000755000175000017500000000000013027007223012434 5ustar domidomiConfig-Model-2.097/MANIFEST0000644000175000017500000001150213027007223013564 0ustar domidomi# This file was automatically generated by Dist::Zilla::Plugin::Manifest v6.008. Build.PL CONTRIBUTING.md Changes LICENSE MANIFEST MANIFEST.SKIP META.json META.yml MODELS README.install.pod README.md 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/Fstab.pm lib/Config/Model/Backend/IniFile.pm lib/Config/Model/Backend/Json.pm lib/Config/Model/Backend/PlainFile.pm lib/Config/Model/Backend/ShellVar.pm lib/Config/Model/Backend/Yaml.pm lib/Config/Model/BackendMgr.pm lib/Config/Model/CheckList.pm lib/Config/Model/Cookbook/CreateModelFromDoc.pod lib/Config/Model/Describe.pm lib/Config/Model/DumpAsData.pm lib/Config/Model/Dumper.pm lib/Config/Model/Exception.pm lib/Config/Model/FuseUI.pm lib/Config/Model/HashId.pm lib/Config/Model/IdElementReference.pm lib/Config/Model/Instance.pm lib/Config/Model/Iterator.pm lib/Config/Model/ListId.pm lib/Config/Model/Lister.pm lib/Config/Model/Loader.pm lib/Config/Model/Manual/ModelCreationAdvanced.pod lib/Config/Model/Manual/ModelCreationIntroduction.pod lib/Config/Model/Node.pm lib/Config/Model/ObjTreeScanner.pm lib/Config/Model/Report.pm lib/Config/Model/Role/Grab.pm lib/Config/Model/Role/HelpAsText.pm lib/Config/Model/Role/NodeLoader.pm lib/Config/Model/Role/WarpMaster.pm lib/Config/Model/SearchElement.pm lib/Config/Model/SimpleUI.pm lib/Config/Model/TermUI.pm lib/Config/Model/TreeSearcher.pm lib/Config/Model/Utils/GenClassPod.pm lib/Config/Model/Value.pm lib/Config/Model/Value/LayeredInclude.pm lib/Config/Model/ValueComputer.pm lib/Config/Model/WarpedNode.pm lib/Config/Model/Warper.pm lib/Config/Model/application.d/multistrap lib/Config/Model/models/Fstab.pl lib/Config/Model/models/Fstab.pod lib/Config/Model/models/Fstab/CommonOptions.pl lib/Config/Model/models/Fstab/Ext2FsOpt.pl lib/Config/Model/models/Fstab/Ext3FsOpt.pl lib/Config/Model/models/Fstab/Ext4FsOpt.pl lib/Config/Model/models/Fstab/FsLine.pl lib/Config/Model/models/Fstab/FsLine.pod lib/Config/Model/models/Fstab/Iso9660_Opt.pl lib/Config/Model/models/Fstab/NoneOptions.pl lib/Config/Model/models/Fstab/SwapOptions.pl lib/Config/Model/models/Fstab/UsbFsOptions.pl lib/Config/Model/models/Multistrap.pl lib/Config/Model/models/Multistrap.pod lib/Config/Model/models/Multistrap/Section.pl lib/Config/Model/models/Multistrap/Section.pod lib/Config/Model/models/PopCon.pl lib/Config/Model/models/PopCon.pod lib/Config/Model/system.d/fstab lib/Config/Model/system.d/popcon t/accept.t t/annotation.t t/apply_fix.t t/array_id.t t/array_with_data_migration.t t/augment_class.t t/auto_load_model.t t/backend_ini.t t/backend_ini_with_section_map.t t/backend_mgr.t t/backend_multiple.t t/backend_plainfile.t t/big_model.pm t/check_list.t t/check_list_warp.t t/cme-function.t t/describe_node.t t/dump_as_data.t t/dump_load_model.pm t/dump_tree.t t/fuse_ui.t t/gen-class-doc.t t/grab.t t/hash_id_of_node.t t/hash_id_of_values.t t/hash_with_data_migration.t t/include.t t/instance.t t/iterator.t t/lib/DummyNode.pm t/load.t t/load_model_snippets.t t/model.t t/model_tests.d/backend-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-shellvar-examples/debian-719256 t/model_tests.d/backend-shellvar-test-conf.pl t/model_tests.d/fstab-examples/t0 t/model_tests.d/fstab-examples/t1 t/model_tests.d/fstab-test-conf.pl t/model_tests.d/layer-examples/mini/etc/foo-config.pl t/model_tests.d/layer-examples/mini/home/joe/foo/config.pl t/model_tests.d/layer-test-conf.pl t/model_tests.d/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/pod.t t/pod_generation.t t/recursive_warp_value.t t/report.t t/search_element.t t/search_in_tree.t t/simple_ui.t t/smooth_upgrade.t t/term_ui.t t/test_ini_backend_model.pl t/test_yaml_model.pl t/value.t t/value_compute.t t/value_refer_to.t t/value_simple_warp.t t/warped_id.t t/warped_node.t t/warped_node_collateral.t t/warped_value.t t/yaml_backend.t weaver.ini Config-Model-2.097/README.install.pod0000644000175000017500000000211013027007223015534 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 L on Fedora is severely oudated. See below for installation. =head2 Other systems For other systems, you should install L from CPAN: cpanp install App::Cme cpanp install Config::ModelConfig-Model-2.097/README.md0000644000175000017500000001546013027007223013721 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. ## If you want to discuss Config::Model ? * Subscribe to the config-model-users list: [http://lists.sourceforge.net/mailman/listinfo/config-model-users](http://lists.sourceforge.net/mailman/listinfo/config-model-users) * [![Codewake](https://www.codewake.com/badges/ask_question.svg)](https://www.codewake.com/p/config-model) ## 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.097/LICENSE0000644000175000017500000006013213027007223013443 0ustar domidomiThis software is Copyright (c) 2005-2016 by Dominique Dumont. This is free software, licensed under: The GNU Lesser General Public License, Version 2.1, February 1999 The GNU Lesser General Public License (LGPL) Version 2.1, February 1999 (The master copy of this license lives on the GNU website.) Copyright (C) 1991, 1999 Free Software Foundation, Inc. 59 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA Everyone is permitted to copy and distribute verbatim copies of this license document, but changing it is not allowed. [This is the first released version of the Lesser GPL. It also counts as the successor of the GNU Library Public License, version 2, hence the version number 2.1.] Preamble The licenses for most software are designed to take away your freedom to share and change it. By contrast, the GNU General Public Licenses are intended to guarantee your freedom to share and change free software--to make sure the software is free for all its users. This license, the Lesser General Public License, applies to some specially designated software packages--typically libraries--of the Free Software Foundation and other authors who decide to use it. You can use it too, but we suggest you first think carefully about whether this license or the ordinary General Public License is the better strategy to use in any particular case, based on the explanations below. When we speak of free software, we are referring to freedom of use, not price. Our General Public Licenses are designed to make sure that you have the freedom to distribute copies of free software (and charge for this service if you wish); that you receive source code or can get it if you want it; that you can change the software and use pieces of it in new free programs; and that you are informed that you can do these things. To protect your rights, we need to make restrictions that forbid distributors to deny you these rights or to ask you to surrender these rights. These restrictions translate to certain responsibilities for you if you distribute copies of the library or if you modify it. For example, if you distribute copies of the library, whether gratis or for a fee, you must give the recipients all the rights that we gave you. You must make sure that they, too, receive or can get the source code. If you link other code with the library, you must provide complete object files to the recipients, so that they can relink them with the library after making changes to the library and recompiling it. And you must show them these terms so they know their rights. We protect your rights with a two-step method: (1) we copyright the library, and (2) we offer you this license, which gives you legal permission to copy, distribute and/or modify the library. To protect each distributor, we want to make it very clear that there is no warranty for the free library. Also, if the library is modified by someone else and passed on, the recipients should know that what they have is not the original version, so that the original author's reputation will not be affected by problems that might be introduced by others. Finally, software patents pose a constant threat to the existence of any free program. We wish to make sure that a company cannot effectively restrict the users of a free program by obtaining a restrictive license from a patent holder. Therefore, we insist that any patent license obtained for a version of the library must be consistent with the full freedom of use specified in this license. Most GNU software, including some libraries, is covered by the ordinary GNU General Public License. This license, the GNU Lesser General Public License, applies to certain designated libraries, and is quite different from the ordinary General Public License. We use this license for certain libraries in order to permit linking those libraries into non-free programs. When a program is linked with a library, whether statically or using a shared library, the combination of the two is legally speaking a combined work, a derivative of the original library. The ordinary General Public License therefore permits such linking only if the entire combination fits its criteria of freedom. The Lesser General Public License permits more lax criteria for linking other code with the library. We call this license the "Lesser" General Public License because it does Less to protect the user's freedom than the ordinary General Public License. It also provides other free software developers Less of an advantage over competing non-free programs. These disadvantages are the reason we use the ordinary General Public License for many libraries. However, the Lesser license provides advantages in certain special circumstances. For example, on rare occasions, there may be a special need to encourage the widest possible use of a certain library, so that it becomes a de-facto standard. To achieve this, non-free programs must be allowed to use the library. A more frequent case is that a free library does the same job as widely used non-free libraries. In this case, there is little to gain by limiting the free library to free software only, so we use the Lesser General Public License. In other cases, permission to use a particular library in non-free programs enables a greater number of people to use a large body of free software. For example, permission to use the GNU C Library in non-free programs enables many more people to use the whole GNU operating system, as well as its variant, the GNU/Linux operating system. Although the Lesser General Public License is Less protective of the users' freedom, it does ensure that the user of a program that is linked with the Library has the freedom and the wherewithal to run that program using a modified version of the Library. The precise terms and conditions for copying, distribution and modification follow. Pay close attention to the difference between a "work based on the library" and a "work that uses the library". The former contains code derived from the library, whereas the latter must be combined with the library in order to run. TERMS AND CONDITIONS FOR COPYING, DISTRIBUTION AND MODIFICATION 0. This License Agreement applies to any software library or other program which contains a notice placed by the copyright holder or other authorized party saying it may be distributed under the terms of this Lesser General Public License (also called "this License"). Each licensee is addressed as "you". A "library" means a collection of software functions and/or data prepared so as to be conveniently linked with application programs (which use some of those functions and data) to form executables. The "Library", below, refers to any such software library or work which has been distributed under these terms. A "work based on the Library" means either the Library or any derivative work under copyright law: that is to say, a work containing the Library or a portion of it, either verbatim or with modifications and/or translated straightforwardly into another language. (Hereinafter, translation is included without limitation in the term "modification".) "Source code" for a work means the preferred form of the work for making modifications to it. For a library, complete source code means all the source code for all modules it contains, plus any associated interface definition files, plus the scripts used to control compilation and installation of the library. Activities other than copying, distribution and modification are not covered by this License; they are outside its scope. The act of running a program using the Library is not restricted, and output from such a program is covered only if its contents constitute a work based on the Library (independent of the use of the Library in a tool for writing it). Whether that is true depends on what the Library does and what the program that uses the Library does. 1. You may copy and distribute verbatim copies of the Library's complete source code as you receive it, in any medium, provided that you conspicuously and appropriately publish on each copy an appropriate copyright notice and disclaimer of warranty; keep intact all the notices that refer to this License and to the absence of any warranty; and distribute a copy of this License along with the Library. You may charge a fee for the physical act of transferring a copy, and you may at your option offer warranty protection in exchange for a fee. 2. You may modify your copy or copies of the Library or any portion of it, thus forming a work based on the Library, and copy and distribute such modifications or work under the terms of Section 1 above, provided that you also meet all of these conditions: a) The modified work must itself be a software library. b) You must cause the files modified to carry prominent notices stating that you changed the files and the date of any change. c) You must cause the whole of the work to be licensed at no charge to all third parties under the terms of this License. d) If a facility in the modified Library refers to a function or a table of data to be supplied by an application program that uses the facility, other than as an argument passed when the facility is invoked, then you must make a good faith effort to ensure that, in the event an application does not supply such function or table, the facility still operates, and performs whatever part of its purpose remains meaningful. (For example, a function in a library to compute square roots has a purpose that is entirely well-defined independent of the application. Therefore, Subsection 2d requires that any application-supplied function or table used by this function must be optional: if the application does not supply it, the square root function must still compute square roots.) These requirements apply to the modified work as a whole. If identifiable sections of that work are not derived from the Library, and can be reasonably considered independent and separate works in themselves, then this License, and its terms, do not apply to those sections when you distribute them as separate works. But when you distribute the same sections as part of a whole which is a work based on the Library, the distribution of the whole must be on the terms of this License, whose permissions for other licensees extend to the entire whole, and thus to each and every part regardless of who wrote it. Thus, it is not the intent of this section to claim rights or contest your rights to work written entirely by you; rather, the intent is to exercise the right to control the distribution of derivative or collective works based on the Library. In addition, mere aggregation of another work not based on the Library with the Library (or with a work based on the Library) on a volume of a storage or distribution medium does not bring the other work under the scope of this License. 3. You may opt to apply the terms of the ordinary GNU General Public License instead of this License to a given copy of the Library. To do this, you must alter all the notices that refer to this License, so that they refer to the ordinary GNU General Public License, version 2, instead of to this License. (If a newer version than version 2 of the ordinary GNU General Public License has appeared, then you can specify that version instead if you wish.) Do not make any other change in these notices. Once this change is made in a given copy, it is irreversible for that copy, so the ordinary GNU General Public License applies to all subsequent copies and derivative works made from that copy. This option is useful when you wish to copy part of the code of the Library into a program that is not a library. 4. You may copy and distribute the Library (or a portion or derivative of it, under Section 2) in object code or executable form under the terms of Sections 1 and 2 above provided that you accompany it with the complete corresponding machine-readable source code, which must be distributed under the terms of Sections 1 and 2 above on a medium customarily used for software interchange. If distribution of object code is made by offering access to copy from a designated place, then offering equivalent access to copy the source code from the same place satisfies the requirement to distribute the source code, even though third parties are not compelled to copy the source along with the object code. 5. A program that contains no derivative of any portion of the Library, but is designed to work with the Library by being compiled or linked with it, is called a "work that uses the Library". Such a work, in isolation, is not a derivative work of the Library, and therefore falls outside the scope of this License. However, linking a "work that uses the Library" with the Library creates an executable that is a derivative of the Library (because it contains portions of the Library), rather than a "work that uses the library". The executable is therefore covered by this License. Section 6 states terms for distribution of such executables. When a "work that uses the Library" uses material from a header file that is part of the Library, the object code for the work may be a derivative work of the Library even though the source code is not. Whether this is true is especially significant if the work can be linked without the Library, or if the work is itself a library. The threshold for this to be true is not precisely defined by law. If such an object file uses only numerical parameters, data structure layouts and accessors, and small macros and small inline functions (ten lines or less in length), then the use of the object file is unrestricted, regardless of whether it is legally a derivative work. (Executables containing this object code plus portions of the Library will still fall under Section 6.) Otherwise, if the work is a derivative of the Library, you may distribute the object code for the work under the terms of Section 6. Any executables containing that work also fall under Section 6, whether or not they are linked directly with the Library itself. 6. As an exception to the Sections above, you may also combine or link a "work that uses the Library" with the Library to produce a work containing portions of the Library, and distribute that work under terms of your choice, provided that the terms permit modification of the work for the customer's own use and reverse engineering for debugging such modifications. You must give prominent notice with each copy of the work that the Library is used in it and that the Library and its use are covered by this License. You must supply a copy of this License. If the work during execution displays copyright notices, you must include the copyright notice for the Library among them, as well as a reference directing the user to the copy of this License. Also, you must do one of these things: a) Accompany the work with the complete corresponding machine-readable source code for the Library including whatever changes were used in the work (which must be distributed under Sections 1 and 2 above); and, if the work is an executable linked with the Library, with the complete machine-readable "work that uses the Library", as object code and/or source code, so that the user can modify the Library and then relink to produce a modified executable containing the modified Library. (It is understood that the user who changes the contents of definitions files in the Library will not necessarily be able to recompile the application to use the modified definitions.) b) Use a suitable shared library mechanism for linking with the Library. A suitable mechanism is one that (1) uses at run time a copy of the library already present on the user's computer system, rather than copying library functions into the executable, and (2) will operate properly with a modified version of the library, if the user installs one, as long as the modified version is interface-compatible with the version that the work was made with. c) Accompany the work with a written offer, valid for at least three years, to give the same user the materials specified in Subsection 6a, above, for a charge no more than the cost of performing this distribution. d) If distribution of the work is made by offering access to copy from a designated place, offer equivalent access to copy the above specified materials from the same place. e) Verify that the user has already received a copy of these materials or that you have already sent this user a copy. For an executable, the required form of the "work that uses the Library" must include any data and utility programs needed for reproducing the executable from it. However, as a special exception, the materials to be distributed need not include anything that is normally distributed (in either source or binary form) with the major components (compiler, kernel, and so on) of the operating system on which the executable runs, unless that component itself accompanies the executable. It may happen that this requirement contradicts the license restrictions of other proprietary libraries that do not normally accompany the operating system. Such a contradiction means you cannot use both them and the Library together in an executable that you distribute. 7. You may place library facilities that are a work based on the Library side-by-side in a single library together with other library facilities not covered by this License, and distribute such a combined library, provided that the separate distribution of the work based on the Library and of the other library facilities is otherwise permitted, and provided that you do these two things: a) Accompany the combined library with a copy of the same work based on the Library, uncombined with any other library facilities. This must be distributed under the terms of the Sections above. b) Give prominent notice with the combined library of the fact that part of it is a work based on the Library, and explaining where to find the accompanying uncombined form of the same work. 8. You may not copy, modify, sublicense, link with, or distribute the Library except as expressly provided under this License. Any attempt otherwise to copy, modify, sublicense, link with, or distribute the Library is void, and will automatically terminate your rights under this License. However, parties who have received copies, or rights, from you under this License will not have their licenses terminated so long as such parties remain in full compliance. 9. You are not required to accept this License, since you have not signed it. However, nothing else grants you permission to modify or distribute the Library or its derivative works. These actions are prohibited by law if you do not accept this License. Therefore, by modifying or distributing the Library (or any work based on the Library), you indicate your acceptance of this License to do so, and all its terms and conditions for copying, distributing or modifying the Library or works based on it. 10. Each time you redistribute the Library (or any work based on the Library), the recipient automatically receives a license from the original licensor to copy, distribute, link with or modify the Library subject to these terms and conditions. You may not impose any further restrictions on the recipients' exercise of the rights granted herein. You are not responsible for enforcing compliance by third parties with this License. 11. If, as a consequence of a court judgment or allegation of patent infringement or for any other reason (not limited to patent issues), conditions are imposed on you (whether by court order, agreement or otherwise) that contradict the conditions of this License, they do not excuse you from the conditions of this License. If you cannot distribute so as to satisfy simultaneously your obligations under this License and any other pertinent obligations, then as a consequence you may not distribute the Library at all. For example, if a patent license would not permit royalty-free redistribution of the Library by all those who receive copies directly or indirectly through you, then the only way you could satisfy both it and this License would be to refrain entirely from distribution of the Library. If any portion of this section is held invalid or unenforceable under any particular circumstance, the balance of the section is intended to apply, and the section as a whole is intended to apply in other circumstances. It is not the purpose of this section to induce you to infringe any patents or other property right claims or to contest validity of any such claims; this section has the sole purpose of protecting the integrity of the free software distribution system which is implemented by public license practices. Many people have made generous contributions to the wide range of software distributed through that system in reliance on consistent application of that system; it is up to the author/donor to decide if he or she is willing to distribute software through any other system and a licensee cannot impose that choice. This section is intended to make thoroughly clear what is believed to be a consequence of the rest of this License. 12. If the distribution and/or use of the Library is restricted in certain countries either by patents or by copyrighted interfaces, the original copyright holder who places the Library under this License may add an explicit geographical distribution limitation excluding those countries, so that distribution is permitted only in or among countries not thus excluded. In such case, this License incorporates the limitation as if written in the body of this License. 13. The Free Software Foundation may publish revised and/or new versions of the Lesser General Public License from time to time. Such new versions will be similar in spirit to the present version, but may differ in detail to address new problems or concerns. Each version is given a distinguishing version number. If the Library specifies a version number of this License which applies to it and "any later version", you have the option of following the terms and conditions either of that version or of any later version published by the Free Software Foundation. If the Library does not specify a license version number, you may choose any version ever published by the Free Software Foundation. 14. If you wish to incorporate parts of the Library into other free programs whose distribution conditions are incompatible with these, write to the author to ask for permission. For software which is copyrighted by the Free Software Foundation, write to the Free Software Foundation; we sometimes make exceptions for this. Our decision will be guided by the two goals of preserving the free status of all derivatives of our free software and of promoting the sharing and reuse of software generally. NO WARRANTY 15. BECAUSE THE LIBRARY IS LICENSED FREE OF CHARGE, THERE IS NO WARRANTY FOR THE LIBRARY, TO THE EXTENT PERMITTED BY APPLICABLE LAW. EXCEPT WHEN OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR OTHER PARTIES PROVIDE THE LIBRARY "AS IS" WITHOUT WARRANTY OF ANY KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE. THE ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE LIBRARY IS WITH YOU. SHOULD THE LIBRARY PROVE DEFECTIVE, YOU ASSUME THE COST OF ALL NECESSARY SERVICING, REPAIR OR CORRECTION. 16. IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY AND/OR REDISTRIBUTE THE LIBRARY AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES, INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING OUT OF THE USE OR INABILITY TO USE THE LIBRARY (INCLUDING BUT NOT LIMITED TO LOSS OF DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD PARTIES OR A FAILURE OF THE LIBRARY TO OPERATE WITH ANY OTHER SOFTWARE), EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF SUCH DAMAGES. END OF TERMS AND CONDITIONS Config-Model-2.097/t/0000755000175000017500000000000013027007223012677 5ustar domidomiConfig-Model-2.097/t/pod_generation.t0000644000175000017500000000240713027007223016064 0ustar domidomi# -*- cperl -*- use ExtUtils::testlib; use Test::More tests => 8; use Test::Memory::Cycle; use Config::Model; use Log::Log4perl qw(:easy); use File::Path; use warnings; no warnings qw(once); use strict; # pseudo root where config files are written by config-model my $wr_root = 'wr_root'; # cleanup before tests rmtree($wr_root); mkpath( $wr_root, { mode => 0755 } ); my $model = Config::Model->new( legacy => 'ignore', ); my $arg = shift || ''; my $trace = $arg =~ /t/ ? 1 : 0; my $log = $arg =~ /l/ ? 1 : 0; Config::Model::Exception::Any->Trace(1) if $arg =~ /e/; my $home = $ENV{HOME} || ""; my $log4perl_user_conf_file = "$home/.log4config-model"; if ( $log and -e $log4perl_user_conf_file ) { Log::Log4perl::init($log4perl_user_conf_file); } else { Log::Log4perl->easy_init( $arg =~ /l/ ? $DEBUG : $WARN ); } ok( 1, "compiled" ); my $inst = $model->instance( root_class_name => 'Master', model_file => 't/big_model.pm', instance_name => 'test1' ); ok( $inst, "created dummy instance" ); $model->generate_doc('Master') if $trace; $model->generate_doc( 'Master', $wr_root ); map { ok( -r "wr_root/Config/Model/models/$_", "Found doc $_" ); } qw /Master.pod SlaveY.pod SlaveZ.pod SubSlave2.pod SubSlave.pod/; memory_cycle_ok($model); Config-Model-2.097/t/backend_multiple.t0000644000175000017500000000616513027007223016376 0ustar domidomi# -*- cperl -*- use ExtUtils::testlib; use Test::More tests => 7; use Test::Memory::Cycle; use Config::Model; use File::Path; use File::Copy; use Test::Warn; use Test::Exception; use warnings; #no warnings qw(once); use strict; use vars qw/$model/; $model = Config::Model->new( legacy => 'ignore', ); my $arg = shift || ''; my $trace = $arg =~ /t/ ? 1 : 0; Config::Model::Exception::Any->Trace(1) if $arg =~ /e/; use Log::Log4perl qw(:easy); my $home = $ENV{HOME} || ""; my $log4perl_user_conf_file = "$home/.log4config-model"; if ( -e $log4perl_user_conf_file ) { Log::Log4perl::init($log4perl_user_conf_file); } else { Log::Log4perl->easy_init( $arg =~ /l/ ? $DEBUG : $WARN ); } ok( 1, "compiled" ); # pseudo root where config files are written by config-model my $wr_root = 'wr_root/'; # cleanup before tests rmtree($wr_root); mkpath( $wr_root, { mode => 0755 } ); $model->create_config_class( 'read_config' => [ { 'auto_create' => '1', 'file' => 'control.pl', 'backend' => 'perl_file', 'config_dir' => 'debian' } ], 'name' => 'Test::Control', 'element' => [ 'source' => { 'type' => 'leaf', value_type => 'string', } ] ); $model->create_config_class( 'read_config' => [ { 'auto_create' => '1', 'file' => 'copyright.pl', 'backend' => 'perl_file', 'config_dir' => 'debian' } ], 'name' => 'Test::Copyright', 'element' => [ 'Format', { 'value_type' => 'uniline', 'type' => 'leaf', }, ] ); $model->create_config_class( 'read_config' => [ { 'auto_create' => '1', 'backend' => 'PlainFile', 'config_dir' => 'debian/source' } ], 'name' => 'Test::Source', 'element' => [ 'format', { 'value_type' => 'uniline', 'type' => 'leaf', } ] ); $model->create_config_class( 'name' => 'Test::Dpkg', 'element' => [ 'control', { 'type' => 'node', 'config_class_name' => 'Test::Control' }, 'copyright', { 'type' => 'node', 'config_class_name' => 'Test::Copyright' }, 'source', { 'type' => 'node', 'config_class_name' => 'Test::Source' } ] ); my $inst = $model->instance( root_class_name => 'Test::Dpkg', root_dir => $wr_root, ); my $root = $inst->config_root; $root->load( "control source=ctrl-source - copyright Format=copyright-format - source format=source-format" ); ok( 1, "loaded data" ); my $dump = $root->dump_tree; print $dump if $trace; $inst->write_back; #check written files foreach (qw!control.pl copyright.pl source/format!) { my $f = $wr_root . "debian/$_"; ok( -e $f, "check written file $f" ); } my $inst2 = $model->instance( root_class_name => 'Test::Dpkg', root_dir => $wr_root, instance_name => 'test2' ); my $root2 = $inst2->config_root; my $dump2 = $root2->dump_tree; is( $dump2, $dump, "check that inst2 is a copy of first instance" ); memory_cycle_ok($model); Config-Model-2.097/t/model.t0000644000175000017500000000757013027007223014175 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 Data::Dumper; use Log::Log4perl qw(:easy :levels); use warnings; no warnings qw(once); use strict; my $arg = shift || ''; my ( $log, $show ) = (0) x 2; my $trace = $arg =~ /t/ ? 1 : 0; $log = 1 if $arg =~ /l/; $show = 1 if $arg =~ /s/; my $home = $ENV{HOME} || ""; my $log4perl_user_conf_file = "$home/.log4config-model"; if ( $log and -e $log4perl_user_conf_file ) { Log::Log4perl::init($log4perl_user_conf_file); } else { Log::Log4perl->easy_init( $log ? $WARN : $ERROR ); } Config::Model::Exception::Any->Trace(1) if $arg =~ /e/; ok( 1, "compiled" ); my $model = Config::Model->new(); my ( $cat, $models ) = Config::Model::Lister::available_models(1); eq_or_diff( $cat->{system}, [qw/fstab popcon/], "check available system models" ); is( $models->{popcon}{model}, 'PopCon', "check available popcon" ); eq_or_diff( $cat->{application}, [qw/multistrap/], "check available application models" ); my $class_name = $model->create_config_class( name => 'Sarge', status => [ D => 'deprecated' ], #could be obsolete, standard description => [ X => 'X-ray (long description)' ], summary => [ X => 'X-ray (summary)' ], element => [ [qw/D X Y Z/] => { type => 'leaf', class => 'Config::Model::Value', value_type => 'enum', choice => [qw/Av Bv Cv/] } ], ); is( $class_name, 'Sarge', "check $class_name class name" ); my $canonical_model = $model->get_model($class_name); print "$class_name model:\n", Dumper($canonical_model) if $trace; eq_or_diff( $model->get_element_model( $class_name, 'D' ), { 'value_type' => 'enum', 'status' => 'deprecated', 'type' => 'leaf', 'class' => 'Config::Model::Value', 'choice' => [ 'Av', 'Bv', 'Cv' ] }, "check $class_name D element model" ); eq_or_diff( $model->get_element_model( $class_name, 'X' ), { 'value_type' => 'enum', 'summary' => 'X-ray (summary)', 'type' => 'leaf', 'class' => 'Config::Model::Value', 'choice' => [ 'Av', 'Bv', 'Cv' ], 'description' => 'X-ray (long description)' }, "check $class_name X element model" ); $class_name = $model->create_config_class( name => 'Captain', element => [ bar => { type => 'node', config_class_name => 'Sarge' } ] ); my @bad_model = ( name => "Master", level => [ [qw/captain many/] => 'important' ], element => [ captain => { type => 'node', config_class_name => 'Captain', }, ], ); throws_ok { $model->create_config_class(@bad_model) } "Config::Model::Exception::ModelDeclaration", "check model with orphan level"; $class_name = $model->create_config_class( name => "Master", level => [ qw/captain/ => 'important' ], force_element_order => [qw/captain array_args hash_args/], element => [ captain => { type => 'node', config_class_name => 'Captain', }, [qw/array_args hash_args/] => { type => 'node', config_class_name => 'Captain', }, ], class_description => "Master description", description => [ captain => "officer", array_args => 'not officer' ] ); ok( 1, "Model created" ); is( $class_name, 'Master', "check $class_name class name" ); $canonical_model = $model->get_model($class_name); print "$class_name model:\n", Dumper($canonical_model) if $trace; memory_cycle_ok( $model, "memory cycles" ); done_testing; Config-Model-2.097/t/cme-function.t0000644000175000017500000000265313027007223015461 0ustar domidomi# -*- cperl -*- use strict; use warnings; use Path::Tiny; use Test::More; use Config::Model qw/cme/; # pseudo root where config files are written by config-model my $wr_root = path('wr_root'); # 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->stringify, ); ok($instance,"new instance created"); } { my $instance = cme('popcon'); ok($instance,"instance found"); # 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"; 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.097/t/backend_mgr.t0000644000175000017500000003214713027007223015327 0ustar domidomi# -*- cperl -*- use ExtUtils::testlib; use Test::More; use Test::Memory::Cycle; use Config::Model; use Path::Tiny 0.070; use Test::Warn; use Test::Exception; use Test::File::Contents; use warnings; no warnings qw(once); use 5.10.1; use strict; use vars qw/$model/; $model = Config::Model->new(); my $arg = shift || ''; my $log = 0; my $trace = $arg =~ /t/ ? 1 : 0; $log = 1 if $arg =~ /l/; Config::Model::Exception::Any->Trace(1) if $arg =~ /e/; use Log::Log4perl qw(:easy); my $home = $ENV{HOME} || ""; my $log4perl_user_conf_file = "$home/.log4config-model"; if ( $log and -e $log4perl_user_conf_file ) { Log::Log4perl::init($log4perl_user_conf_file); } else { Log::Log4perl->easy_init($ERROR); } ok( 1, "compiled" ); # pseudo root for config files my $wr_root = path('wr_root'); my $root1 = $wr_root->child('test1'); my $root2 = $wr_root->child('test2'); my $root3 = $wr_root->child('test3'); my $conf_dir = '/etc/test/'; # cleanup before tests $wr_root->remove_tree; # model declaration $model->create_config_class( name => 'Level2', element => [ [qw/X Y Z/] => { type => 'leaf', value_type => 'enum', choice => [qw/Av Bv Cv/] } ] ); $model->create_config_class( name => 'Level1', # try first to read with cds string and then custom class read_config => [ { backend => 'cds_file', config_dir => $conf_dir }, { backend => 'custom', config_dir => $conf_dir, class => 'Level1Read', function => 'read_it' } ], write_config => [ { backend => 'cds_file', config_dir => $conf_dir }, { backend => 'perl_file', config_dir => $conf_dir, auto_create => 1 }, { backend => 'ini_file', config_dir => $conf_dir } ], element => [ bar => { type => 'node', config_class_name => 'Level2', } ] ); $model->create_config_class( name => 'SameReadWriteSpec', # try first to read with cds string and then custom class read_config => [ { backend => 'cds_file', config_dir => $conf_dir }, { backend => 'custom', class => 'SameRWSpec', config_dir => $conf_dir }, { backend => 'ini_file', config_dir => $conf_dir, auto_create => 1 } ], element => [ bar => { type => 'node', config_class_name => 'Level2', }, int_with_max => {qw/type leaf value_type integer max 10/}, ] ); $model->create_config_class( name => 'Master', read_config => [ { backend => 'cds_file', config_dir => $conf_dir }, { backend => 'perl_file', config_dir => $conf_dir }, { backend => 'ini_file', config_dir => $conf_dir }, { backend => 'custom', class => 'MasterRead', config_dir => $conf_dir, function => 'read_it' } ], write_config => [ { backend => 'cds_file', config_dir => $conf_dir }, { backend => 'perl_file', config_dir => $conf_dir }, { backend => 'ini_file', config_dir => $conf_dir }, { class => 'MasterRead', function => 'wr_stuff', config_dir => $conf_dir, auto_create => 1 } ], element => [ aa => { type => 'leaf', value_type => 'string' }, level1 => { type => 'node', config_class_name => 'Level1', }, samerw => { type => 'node', config_class_name => 'SameReadWriteSpec', }, ] ); $model->create_config_class( name => 'FromScratch', read_config => [ { backend => 'cds_file', config_dir => $conf_dir, auto_create => 1 }, ], element => [ aa => { type => 'leaf', value_type => 'string' }, ] ); $model->create_config_class( name => 'CdsWithFile', read_config => [ { backend => 'cds_file', config_dir => $conf_dir, file => 'scratch_inst.cds' }, ], element => [ aa => { type => 'leaf', value_type => 'string' }, ] ); $model->create_config_class( name => 'CdsWithNoFile', read_config => [ { backend => 'cds_file' }, ], element => [ aa => { type => 'leaf', value_type => 'string' }, ] ); $model->create_config_class( name => 'SimpleRW', read_config => [ { backend => 'custom', config_dir => $conf_dir, class => 'SimpleRW', file => 'toto.conf' }, ], element => [ aa => { type => 'leaf', value_type => 'string' }, ] ); #global variable to snoop on read config action my %result; package MasterRead; my $custom_aa = 'aa was set (custom mode)'; sub read_it { my %args = @_; $result{master_read} = $args{config_dir}; $args{object}->store_element_value( 'aa', $custom_aa ); } sub wr_stuff { my %args = @_; $result{wr_stuff} = $args{config_dir}; $result{wr_root_name} = $args{object}->name; } package Level1Read; sub read_it { my %args = @_; $result{level1_read} = $args{config_dir}; $args{object}->load('bar X=Cv'); } package SameRWSpec; sub read { my %args = @_; $result{same_rw_read} = $args{config_dir}; $args{object}->load('bar Y=Cv'); } sub write { my %args = @_; $result{same_rw_write} = $args{config_dir}; } package SimpleRW; sub read { my %args = @_; $result{simple_rw}{rfile} = $args{file_path}; my $io = $args{io_handle}; return 0 unless defined $io; $args{object}->load( $io->getlines ); return 1; } sub write { my %args = @_; $result{simple_rw}{wfile} = $args{file_path}; my $io = $args{io_handle}; return 0 unless defined $io; my $dump = $args{object}->dump_tree(); $io->print($dump); } package main; my $i_fail = $model->instance( instance_name => 'failed_inst', root_class_name => 'Master', root_dir => $root1->stringify, backend => 'perl_file', ); throws_ok { $i_fail->config_root->init; } qr/failed_inst.pl/, "read with forced perl_file backend fails (normal: no perl file)"; # check that conf dir was NOT read when instance was created is( $result{master_read}, undef, "Master read conf dir" ); my $i_zero = $model->instance( instance_name => 'zero_inst', root_class_name => 'Master', root_dir => $root1->stringify, ); ok( $i_zero, "Created instance (from scratch)" ); my $master = $i_zero->config_root; ok( $master, "Master node created" ); $master->init; # check that conf dir was read when instance was created is( $result{master_read}, $conf_dir, "Master read conf dir" ); is( $master->fetch_element_value('aa'), $custom_aa, "Master custom read" ); my $level1; $level1 = $master->fetch_element('level1'); $level1->init; ok( $level1, "Level1 object created" ); is( $level1->grab_value('bar X'), 'Cv', "Check level1 custom read" ); is( $result{level1_read}, $conf_dir, "check level1 custom read conf dir" ); my $same_rw = $master->fetch_element('samerw'); ok( $same_rw, "SameRWSpec object created" ); is( $same_rw->grab_value('bar Y'), 'Cv', "Check samerw custom read" ); is( $result{same_rw_read}, $conf_dir, "check same_rw_spec custom read conf dir" ); is( $i_zero->count_write_back, 10, "check that write call back are present" ); # perform write back of dodu tree dump string $i_zero->write_back( backend => 'all', force => 1 ); # check written files foreach my $suffix (qw/cds ini/) { map { my $f = $root1->child("$conf_dir/$_.$suffix"); ok( $f->is_file, "check written file $f" ); } ( 'zero_inst', 'zero_inst/level1', 'zero_inst/samerw' ); } foreach my $suffix (qw/pl/) { map { my $f = $root1->child("$conf_dir/$_.$suffix"); ok( $f->is_file, "check written file $f" ); } ( 'zero_inst', 'zero_inst/level1' ); } # check called write routine is( $result{wr_stuff}, $conf_dir, 'check custom write dir' ); is( $result{wr_root_name}, 'Master', 'check custom conf root to write' ); # perform write back of dodu tree dump string in an overridden dir my $override = 'etc/wr_2/'; $i_zero->write_back( backend => 'all', config_dir => $override, force => 1 ); # check written files foreach my $suffix (qw/cds ini/) { map { ok( $root1->child("$override$_.$suffix")->is_file, "check written file ".$root1->child("$override$_.$suffix") ); } ( 'zero_inst', 'zero_inst/level1', 'zero_inst/samerw' ); } foreach my $suffix (qw/pl/) { map { ok( $root1->child("$override$_.$suffix")->is_file, "check written file ".$root1->child("$override$_.$suffix") ); } ( 'zero_inst', 'zero_inst/level1' ); } is( $result{wr_stuff}, $override, 'check custom overridden write dir' ); my $dump = $master->dump_tree( skip_auto_write => 'cds_file' ); print "Master dump:\n$dump\n" if $trace; is( $dump, qq!aa="$custom_aa" -\n!, "check master dump" ); $dump = $level1->dump_tree( skip_auto_write => 'cds_file' ); print "Level1 dump:\n$dump\n" if $trace; is( $dump, qq! bar\n X=Cv - -\n!, "check level1 dump" ); my $inst2 = 'second_inst'; my %cds = ( $inst2 => 'aa="aa was set by file" - ', "$inst2/level1" => 'bar X=Av Y=Bv - ' ); my $dir2 = $root2->child("etc/test/"); $dir2->child($inst2)->mkpath(); # write input config files foreach my $f ( keys %cds ) { my $fout = $dir2->child($f.'.cds'); next if -r $fout; $fout->spew($cds{$f}); } # create another instance my $test2_inst = $model->instance( root_class_name => 'Master', instance_name => $inst2, root_dir => $root2->stringify, ); ok( $test2_inst, "created second instance" ); # access level1 to autoread it my $root_2 = $test2_inst->config_root; my $level1_2 = $root_2->fetch_element('level1'); $level1_2->init; is( $root_2->grab_value('aa'), 'aa was set by file', "$inst2: check that cds file was read" ); my $dump2 = $root_2->dump_tree(); print "Read Master dump:\n$dump2\n" if $trace; my $expect2 = 'aa="aa was set by file" level1 bar X=Av Y=Bv - - samerw bar Y=Cv - - - '; is( $dump2, $expect2, "$inst2: check dump" ); # create another instance to load ini files my $ini_inst = $model->instance( root_class_name => 'Master', instance_name => 'ini_inst' ); ok( $ini_inst, "Created instance to load ini files" ); my $expect_custom = 'aa="aa was set (custom mode)" level1 bar X=Cv - - samerw bar Y=Cv - - - '; $dump = $ini_inst->config_root->dump_tree; is( $dump, $expect_custom, "ini_test: check dump" ); # create another instance to load pl files my $pl_inst = $model->instance( root_class_name => 'Master', instance_name => 'pl_inst' ); ok( $pl_inst, "Created instance to load pl files" ); $dump = $pl_inst->config_root->dump_tree; is( $dump, $expect_custom, "pl_test: check dump" ); #create from scratch instance my $scratch_i = $model->instance( root_class_name => 'FromScratch', instance_name => 'scratch_inst', root_dir => $root3->stringify, ); ok( $scratch_i, "Created instance from scratch to load cds files" ); $scratch_i->config_root->load("aa=toto"); $scratch_i->write_back; ok( -e "$root3/$conf_dir/scratch_inst.cds", "wrote cds config file" ); # create model for simple RW class my $cdswf = $model->instance( root_class_name => 'CdsWithFile', instance_name => 'cds_with_file_inst', root_dir => $root3->stringify, ); ok( $cdswf, "Created instance to load custom cds file" ); $cdswf->config_root->load("aa=toto2"); my $expect = 'aa=toto2 - '; is( $cdswf->config_root->dump_tree, $expect, "check dump" ); $cdswf->write_back; my $toto_conf = $root3->child("$conf_dir/scratch_inst.cds")->copy( $root3->child("$conf_dir/toto.conf")) or die "can't copy scratch_inst.cds to toto.conf:$!"; my $ctoto = $model->instance( root_class_name => 'SimpleRW', instance_name => 'custom_toto', root_dir => $root3->stringify, ); ok( $ctoto, "Created instance to load custom custom toto file" ); is( $ctoto->config_root->dump_tree, $expect, "check dump" ); $ctoto->config_root->load("aa=toto3"); $ctoto->write_back; map { is( $result{simple_rw}{$_}, 'wr_root/test3//etc/test/toto.conf', "Check Simple_Rw cb file argument ($_)" ) } qw/rfile wfile/; file_contents_eq( $toto_conf, "aa=toto3 -\n", "checked file written by simpleRW" ); # test config-file override, reading cds file my $scratch_conf = 'etc/test/scratch_inst.cds'; my $cdswnf = $model->instance( root_class_name => 'CdsWithNoFile', instance_name => 'cds_with_no_file_inst', root_dir => $root3->stringify, config_file => $scratch_conf, ); ok( $cdswnf, "Created instance to load overridden cds config file" ); $expect = 'aa=toto2 - '; is( $cdswnf->config_root->dump_tree, $expect, "check dump" ); $cdswnf->config_root->load("aa=toto4"); $cdswnf->write_back( config_file => $scratch_conf ); file_contents_eq( "$root3/$scratch_conf", "aa=toto4 -\n", "checked file written by simpleRW" ); memory_cycle_ok($model); done_testing; Config-Model-2.097/t/multi_warp_value.t0000644000175000017500000001071713027007223016451 0ustar domidomi# -*- cperl -*- use warnings; use ExtUtils::testlib; use Test::More tests => 63; use Test::Differences; use Test::Memory::Cycle; use Config::Model; use Storable qw/dclone/; use strict; my $arg = shift || ''; my $trace = $arg =~ /t/ ? 1 : 0; Config::Model::Exception::Any->Trace(1) if $arg =~ /e/; use Log::Log4perl qw(:easy); Log::Log4perl->easy_init( $arg =~ /l/ ? $TRACE : $WARN ); ok( 1, "Compilation done" ); my @m1 = qw/A1 B1/; my @m2 = qw/A2 B2 C2/; my @m3 = qw/A3 B3/; my @rules; foreach my $c1 (@m1) { foreach my $c2 (@m2) { foreach my $c3 (@m3) { push @rules, [ $c1, $c2, $c3 ], { default => "m$c1$c2$c3" }; } } } #use Data::Dumper; print Dumper \@rules ; # minimal set up to get things working my $model = Config::Model->new( legacy => 'ignore', ); my $model_data = { name => 'Master', 'element' => [ macro1 => { type => 'leaf', value_type => 'enum', choice => \@m1 }, macro2 => { type => 'leaf', value_type => 'enum', choice => \@m2 }, macro3 => { type => 'leaf', value_type => 'enum', choice => \@m3 }, m1 => { type => 'leaf', value_type => 'string', 'warp' => { follow => [ '- macro1', ' - macro2', '- macro3' ], rules => \@rules } }, 'm2' => { type => 'leaf', value_type => 'string', default => 'unsatisfied', 'warp' => { follow => [ '- macro1', ' - macro2', '- macro3' ], 'rules' => [ [ 'A1', 'A2', 'A3' ] => { default => '3xA' }, [ 'B1', [ 'B2', 'C2' ], 'B3' ] => { default => '3x[BC]' }, ] }, }, 'm3' => { type => 'leaf', value_type => 'string', default => 'unsatisfied', 'warp' => { follow => '- macro2', 'rules' => [ [ 'B2', 'A2' ] => { default => 'A2 B2 rule' }, 'C2' => { default => 'C2 rule' }, ] }, }, 'm4' => { type => 'leaf', value_type => 'string', default => 'unsatisfied', 'warp' => { follow => { m1 => '- macro1', m2 => ' - macro2', m3 => '- macro3' }, 'rules' => [ '$m1 eq "A1" and $m2 eq "A2" and $m3 eq "A3"' => { default => '3xA' }, '($m1 eq "B1") and ($m2 eq "B2" or $m2 eq "C2") and ($m3 eq "B3")' => { default => '3x[BC]' }, ] }, }, ] }; my $copy = dclone $model_data ; $model->create_config_class(%$copy); my $inst = $model->instance( root_class_name => 'Master', instance_name => 'test1' ); ok( $inst, "created dummy instance" ); my $root = $inst->config_root; use Config::Model::Warper; eq_or_diff( [ Config::Model::Warper::_dclone_key('foo') ], ['foo'], "Test _dclone_key (single key)" ); #use Devel::TraceCalls; #trace_calls {Class => "Config::Model::Value",}; #trace_calls {Class => "Config::Model::WarpedThing",}; foreach my $c1 (@m1) { ok( $root->load("macro1=$c1"), "Setting Root macro1 to $c1" ); foreach my $c2 (@m2) { ok( $root->load("macro2=$c2"), "Setting Root macro2 to $c2" ); foreach my $c3 (@m3) { ok( $root->load("macro3=$c3"), "Setting Root macro3 to $c3" ); my $vm1 = $root->grab_value('m1'); is( $vm1, "m$c1$c2$c3", "Reading Root slot m1: $vm1" ); my $index = "$c1$c2$c3"; my $m2_val = $index eq 'A1A2A3' ? '3xA' : $index =~ /B1[BC]2B3/ ? '3x[BC]' : 'unsatisfied'; is( $root->grab_value('m2'), $m2_val, "Reading Root slot m2" ); is( $root->grab_value('m4'), $m2_val, "Reading Root slot m4" ); } } } my @test = ( [ "macro2=A2", "A2 B2 rule" ], [ "macro2=C2", "C2 rule" ], [ "macro2=B2", "A2 B2 rule" ], ); foreach my $u_test (@test) { my ( $load, $exp ) = @$u_test; $root->load($load); is( $root->grab_value('m3'), $exp, "test m3 with $load" ); } memory_cycle_ok($model); Config-Model-2.097/t/warped_value.t0000644000175000017500000004637213027007223015556 0ustar domidomi# -*- cperl -*- use warnings; use ExtUtils::testlib; use Test::More; use Test::Differences; use Test::Memory::Cycle; use Test::Exception; use Config::Model; use Config::Model::ValueComputer; use Log::Log4perl qw(:easy); use strict; my ( $log, $show ) = (0) x 3; my $arg = shift || ''; my $trace = $arg =~ /t/ ? 1 : 0; $log = 1 if $arg =~ /l/; $show = 1 if $arg =~ /s/; Config::Model::Exception::Any->Trace(1) if $arg =~ /e/; my $home = $ENV{HOME} || ""; my $log4perl_user_conf_file = "$home/.log4config-model"; if ( $log and -e $log4perl_user_conf_file ) { Log::Log4perl::init($log4perl_user_conf_file); } else { Log::Log4perl->easy_init( $arg =~ /l/ ? $DEBUG : $WARN ); } ok( 1, "Compilation done" ); my $model = Config::Model->new(); $model->create_config_class( name => "RSlave", element => [ recursive_slave => { type => 'hash', index_type => 'string', cargo => { type => 'node', config_class_name => 'RSlave' }, }, big_compute => { type => 'hash', index_type => 'string', cargo => { type => 'leaf', value_type => 'string', compute => { variables => { 'm' => '! macro', }, formula => 'macro is $m, my idx: &index, ' . 'my element &element, ' . 'upper element &element( - ), ' . 'up idx &index( - )', } }, }, big_replace => { type => 'leaf', value_type => 'string', compute => { formula => 'trad idx $replace{&index(-)}', replace => { l1 => 'level1', l2 => 'level2' } } }, [qw/bar foo foo2/] => { type => 'node', config_class_name => 'Slave' }, macro_replace => { type => 'hash', index_type => 'string', cargo => { type => 'leaf', value_type => 'string', compute => { formula => 'trad macro is $replace{$m}', variables => { 'm' => '! macro', }, replace => { A => 'macroA', B => 'macroB', C => 'macroC' }, } }, } ], ); $model->create_config_class( name => "Slave", 'element' => [ [qw/X Y Z/] => { type => 'leaf', value_type => 'enum', choice => [qw/Av Bv Cv/], warp => { follow => '- - macro', rules => { A => { default => 'Av' }, B => { default => 'Bv' } } } }, 'recursive_slave' => { type => 'hash', index_type => 'string', cargo => { type => 'node', config_class_name => 'RSlave', }, }, W => { type => 'leaf', value_type => 'enum', level => 'hidden', warp => { follow => '- - macro', 'rules' => { A => { default => 'Av', level => 'normal', choice => [qw/Av Bv Cv/], }, B => { default => 'Bv', level => 'normal', choice => [qw/Av Bv Cv/] } } }, }, Comp => { type => 'leaf', value_type => 'string', compute => { formula => 'macro is $m', variables => { 'm' => '- - macro' }, }, }, warped_by_location => { type => 'leaf', value_type => 'uniline', default => 'slaved', warp => { rules => [ '&location =~ /recursive/', { 'default' => 'rslaved' } ] }, }, ] ); $model->create_config_class( name => "Master", element => [ get_element => { type => 'leaf', value_type => 'enum', choice => [qw/m_value_element compute_element/] }, where_is_element => { type => 'leaf', value_type => 'enum', choice => [qw/get_element/] }, macro => { type => 'leaf', value_type => 'enum', mandatory => 1, choice => [qw/A B C D/] }, m_value_out => { type => 'leaf', value_type => 'uniline', warp => { follow => '- macro', 'rules' => [ "B" => { level => 'hidden', }, ] } }, m2_value_out => { type => 'leaf', value_type => 'uniline', warp => { follow => { m => '- macro', m2 => '- macro2' }, rules => [ '$m eq "A" or $m2 eq "A"' => { level => 'hidden', }, ] } }, macro2 => { type => 'leaf', value_type => 'enum', level => 'hidden', warp => { follow => '- macro', 'rules' => [ "B" => { level => 'normal', choice => [qw/A B C D/] }, ] } }, 'm_value' => { type => 'leaf', value_type => 'enum', level => 'hidden', 'warp' => { follow => { m => '- macro' }, 'rules' => [ '$m eq "A" or $m eq "D"' => { choice => [qw/Av Bv/], level => 'normal', help => { Av => 'Av help' }, }, '$m eq "B"' => { choice => [qw/Bv Cv/], level => 'normal', help => { Bv => 'Bv help' }, }, '$m eq "C"' => { choice => [qw/Cv/], level => 'normal', help => { Cv => 'Cv help' }, } ] } }, 'm_value_old' => { type => 'leaf', value_type => 'enum', level => 'hidden', 'warp' => { follow => '- macro', 'rules' => [ [qw/A D/] => { choice => [qw/Av Bv/], level => 'normal', help => { Av => 'Av help' }, }, B => { choice => [qw/Bv Cv/], level => 'normal', help => { Bv => 'Bv help' }, }, C => { choice => [qw/Cv/], level => 'normal', help => { Cv => 'Cv help' }, } ] } }, 'compute' => { type => 'leaf', value_type => 'string', compute => { formula => 'macro is $m, my element is &element', variables => { 'm' => '! macro' }, }, }, 'var_path' => { type => 'leaf', value_type => 'string', mandatory => 1, # will croak if value cannot be computed compute => { formula => 'get_element is $replace{$s}, indirect value is \'$v\'', variables => { 's' => '! $where', where => '! where_is_element', v => '! $replace{$s}', }, replace => {qw/m_value_element m_value compute_element compute/} } }, 'class' => { type => 'hash', index_type => 'string', cargo => { type => 'leaf', value_type => 'string' }, }, 'warped_out_ref' => { type => 'leaf', refer_to => '! class', value_type => 'reference', level => 'hidden', warp => { follow => { m => '- macro', m2 => '- macro2' }, rules => [ '$m eq "A" or $m2 eq "A"' => { level => 'normal', }, ] } }, [qw/bar foo foo2/] => { type => 'node', config_class_name => 'Slave' }, 'ClientAliveCheck', { 'value_type' => 'boolean', 'upstream_default' => '0', 'type' => 'leaf', }, 'ClientAliveInterval', { 'value_type' => 'integer', 'level' => 'hidden', 'min' => '1', 'warp' => { 'follow' => { 'c_a_check' => '- ClientAliveCheck' }, 'rules' => [ '$c_a_check == 1', { 'level' => 'normal' } ] }, 'type' => 'leaf' }, ] ); my $inst = $model->instance( root_class_name => 'Master', instance_name => 'test1' ); ok( $inst, "created dummy instance" ); my $root = $inst->config_root; my $mvo = $root->fetch_element('m_value_out'); isa_ok( $mvo->{warper}, 'Config::Model::Warper', "check warper object" ); my $macro = $root->fetch_element('macro'); my @macro_slaves = ('Warper of Master m_value_out'); eq_or_diff( [ map { $_->name } $macro->get_depend_slave ], \@macro_slaves, "check m_value_out warper" ); my $mvo2 = $root->fetch_element('m2_value_out'); isa_ok( $mvo2->{warper}, 'Config::Model::Warper', "check warper object" ); push @macro_slaves, 'Warper of Master m2_value_out', 'Warper of Master macro2'; eq_or_diff( [ sort map { $_->name } $macro->get_depend_slave ], [ sort @macro_slaves ], "check m_value_out and m2_value_out warper" ); eq_or_diff( [ $root->get_element_name() ], [ qw'get_element where_is_element macro m_value_out m2_value_out compute var_path class bar foo foo2 ClientAliveCheck' ], "Elements of Master" ); # query the model instead of the instance eq_or_diff( [ $model->get_element_name( class => 'Slave', ) ], [qw'X Y Z recursive_slave Comp warped_by_location'], "Elements of Slave from the model" ); my $slave = $root->fetch_element('bar'); ok( $slave, "Created slave(bar)" ); eq_or_diff( [ $slave->get_element_name() ], [qw'X Y Z recursive_slave Comp warped_by_location'], "Elements of Slave from the object" ); throws_ok { $slave->fetch_element('W')->fetch; } qr/unavailable/, "reading slave->W (undef value_type error)"; is( $slave->fetch_element('X')->fetch, undef, "reading slave->X (undef)" ); is( $macro->store('B'), 1, "setting master->macro to B" ); eq_or_diff( [ $root->get_element_name() ], [ qw'get_element where_is_element macro m2_value_out macro2 m_value m_value_old compute var_path class bar foo foo2 ClientAliveCheck' ], "Elements of Master when macro = B" ); is( $root->fetch_element('macro2')->store('A'), 1, "setting master->macro2 to A" ); is_deeply( [ $root->get_element_name() ], [ qw'get_element where_is_element macro macro2 m_value m_value_old compute var_path class warped_out_ref bar foo foo2 ClientAliveCheck' ], "Elements of Master when macro = B macro2 = A" ); $root->fetch_element('class')->fetch_with_id('foo')->store('foo_v'); $root->fetch_element('class')->fetch_with_id('bar')->store('bar_v'); is( $root->fetch_element('warped_out_ref')->store('foo'), 1, "setting master->warped_out_ref to foo" ); is( $root->fetch_element('macro')->store('A'), 1, "setting master->macro to A" ); map { is( $slave->fetch_element($_)->fetch, 'Av', "reading slave->$_ (Av)" ); } qw/X Y Z/; is( $root->fetch_element('macro')->store('C'), 1, "setting master->macro to C" ); is( $root->fetch_element('m_value')->get_help('Cv'), 'Cv help', 'test m_value help with macro=C' ); is( $slave->fetch_element('X')->fetch, undef, "reading slave->X (undef)" ); $root->fetch_element('macro')->store('A'); is( $root->fetch_element('m_value')->store('Av'), 1, 'test m_value with macro=A' ); is( $root->fetch_element('m_value_old')->store('Av'), 1, 'test m_value_old with macro=A' ); is( $root->fetch_element('m_value')->get_help('Av'), 'Av help', 'test m_value help with macro=A' ); is( $root->fetch_element('m_value')->get_help('Cv'), undef, 'test m_value help with macro=A' ); $root->fetch_element('macro')->store('D'); is( $root->fetch_element('m_value')->fetch, 'Av', 'test m_value with macro=D' ); is( $root->fetch_element('m_value_old')->fetch, 'Av', 'test m_value_old with macro=D' ); $root->fetch_element('macro')->store('A'); is_deeply( [ $slave->get_element_name() ], [qw/X Y Z recursive_slave W Comp warped_by_location/], "Slave elements from the object (W pops in when macro is set to A)" ); $root->fetch_element('macro')->store('B'); is_deeply( [ $slave->get_element_name() ], [qw/X Y Z recursive_slave W Comp warped_by_location/], "Slave elements from the object" ); map { is( $slave->fetch_element($_)->fetch, 'Bv', "reading slave->$_ (Bv)" ); } qw/X Y Z/; is( $slave->fetch_element('Y')->store('Cv'), 1, 'Set slave->Y to Cv' ); # testing warp in warp out $root->fetch_element('macro')->store('C'); is( $slave->is_element_available( name => 'W' ), 0, " test W is not available" ); $root->fetch_element('macro')->store('B'); is( $slave->is_element_available( name => 'W' ), 1, " test W is available" ); $root->fetch_element('macro')->store('C'); map { is( $slave->fetch_element($_)->fetch, undef, "reading slave->$_ (undef)" ); } qw/X Z/; is( $slave->fetch_element('Y')->fetch, 'Cv', "reading slave->Y (Cv)" ); is( $slave->fetch_element('Comp')->fetch, 'macro is C', "reading slave->Comp" ); is( $root->fetch_element('m_value')->store('Cv'), 1, 'set m_value to Cv' ); my $rslave1 = $slave->fetch_element('recursive_slave')->fetch_with_id('l1'); my $rslave2 = $rslave1->fetch_element('recursive_slave')->fetch_with_id('l2'); my $big_compute_obj = $rslave2->fetch_element('big_compute')->fetch_with_id('b1'); isa_ok( $big_compute_obj, 'Config::Model::Value', 'Created new big compute object' ); my $bc_val = $rslave2->fetch_element('big_compute')->fetch_with_id("test_1")->fetch; is( $bc_val, 'macro is C, my idx: test_1, my element big_compute, upper element recursive_slave, up idx l2', 'reading slave->big_compute(test1)' ); is( $big_compute_obj->fetch, 'macro is C, my idx: b1, my element big_compute, upper element recursive_slave, up idx l2', 'reading slave->big_compute(b1)' ); is( $rslave1->fetch_element('big_replace')->fetch(), 'trad idx level1', 'reading rslave1->big_replace(br1)' ); is( $rslave2->fetch_element('big_replace')->fetch(), 'trad idx level2', 'reading rslave2->big_replace(br1)' ); is( $rslave1->fetch_element('macro_replace')->fetch_with_id('br1')->fetch, 'trad macro is macroC', 'reading rslave1->macro_replace(br1)' ); is( $rslave2->fetch_element('macro_replace')->fetch_with_id('br1')->fetch, 'trad macro is macroC', 'reading rslave2->macro_replace(br1)' ); is( $root->fetch_element('compute')->fetch(), 'macro is C, my element is compute', 'reading root->compute' ); my @masters = $root->fetch_element('macro')->get_depend_slave(); my @names = sort map { $_->name } @masters; print "macro controls:\n\t", join( "\n\t", @names ), "\n" if $trace; is( scalar @masters, 16, 'reading macro slaves' ); eq_or_diff( \@names, [ 'Master compute', 'Warper of Master m2_value_out', 'Warper of Master m_value', 'Warper of Master m_value_old', 'Warper of Master m_value_out', 'Warper of Master macro2', 'Warper of Master warped_out_ref', 'Warper of bar W', 'Warper of bar X', 'Warper of bar Y', 'Warper of bar Z', 'bar Comp', 'bar recursive_slave:l1 macro_replace:br1', 'bar recursive_slave:l1 recursive_slave:l2 big_compute:b1', 'bar recursive_slave:l1 recursive_slave:l2 big_compute:test_1', 'bar recursive_slave:l1 recursive_slave:l2 macro_replace:br1', ], "check names of values using 'macro' element" ); Config::Model::Exception::Any->Trace(1); throws_ok { $root->fetch_element('var_path')->fetch; } qr/'! where_is_element' is undef/, 'reading var_path while where_is_element variable is undef'; # set one variable of the formula $root->fetch_element('where_is_element')->store('get_element'); throws_ok { $root->fetch_element('var_path')->fetch; } qr/'! where_is_element' is 'get_element'/, 'reading var_path while where_is_element is defined' ; throws_ok { $root->fetch_element('var_path')->fetch; } qr/Undefined mandatory value/, 'reading var_path while get_element variable is undef'; # set the other variable of the formula $root->fetch_element('get_element')->store('m_value_element'); is( $root->fetch_element('var_path')->fetch(), 'get_element is m_value, indirect value is \'Cv\'', "reading var_path through m_value element" ); # modify the other variable of the formula $root->fetch_element('get_element')->store('compute_element'); is( $root->fetch_element('var_path')->fetch(), 'get_element is compute, indirect value is \'macro is C, my element is compute\'', "reading var_path through compute element" ); $root->fetch_element('ClientAliveCheck')->store(0); throws_ok { $root->fetch_element('ClientAliveInterval')->fetch; } qr/unavailable element/, 'reading ClientAliveInterval when ClientAliveCheck is 0'; $root->fetch_element('ClientAliveCheck')->store(1); $root->fetch_element('ClientAliveInterval')->store(10); is( $root->fetch_element('ClientAliveInterval')->fetch, 10, "check ClientAliveInterval" ); my %loc_h = ( qw/bar slaved foo2 slaved/, 'bar recursive_slave:l1 foo2' => 'rslaved', 'bar recursive_slave:l1 recursive_slave:l2 foo2' => 'rslaved' ); foreach my $k ( sort keys %loc_h ) { my $path = "$k warped_by_location"; is( $root->grab_value($path), $loc_h{$k}, "check &location with $path" ); } # test warp in layered mode my $layered_i = $model->instance( root_class_name => 'Master', instance_name => 'test_layered' ); ok( $layered_i, "created layered instance" ); my $l_root = $layered_i->config_root; $layered_i->layered_start; my $l_macro = $l_root->fetch_element('macro'); $l_macro->store('D'); my $l_mv = $l_root->fetch_element('m_value'); $layered_i->layered_stop; $l_mv->store('Av'); is( $l_mv->fetch, 'Av', "test warp in layered mode" ); memory_cycle_ok( $model, "test memory cycle" ); done_testing ; Config-Model-2.097/t/fuse_ui.t0000644000175000017500000001210013027007223014515 0ustar domidomi# -*- cperl -*- use ExtUtils::testlib; use Test::More; use Path::Tiny; use Test::Memory::Cycle; use Config::Model; use Config; # Config::Model::FuseUI is loaded later within an eval if ( $Config{osname} ne 'linux' ) { plan skip_all => "Not a Linux system"; } my @lsmod = eval { `lsmod`; }; if ($@) { plan skip_all => "Cannot check is fuse module is loaded: $@"; } if ( not grep ( /fuse/, @lsmod ) ) { plan skip_all => "fuse module is not loaded"; } if ( not grep ( m!/!, `bash -c 'type fusermount'` ) ) { plan skip_all => "fusermount not found"; } my $umount_str = `bash -c 'umount --version'`; my ($umount_v) = $umount_str =~ / (\d+\.\d+)/; if ( $umount_v + 0 < 2.18 ) { plan skip_all => "Did not find umount with version >= 2.18"; } eval { require Config::Model::FuseUI; }; if ($@) { plan skip_all => "Config::Model::FuseUI or Fuse is not installed"; } else { # the forked process prints an ok, hence done_testing cannot be used plan tests => 17; } use warnings; use strict; # required to handle warnings in forked process local $SIG{__WARN__} = sub { die $_[0] unless $_[0] =~ /deprecated/ }; use Data::Dumper; use POSIX ":sys_wait_h"; my $arg = shift || ''; my $log = 0; my $trace = $arg =~ /t/ ? 1 : 0; my $fuse_debug = $arg =~ /f/ ? 1 : 0; $log = 1 if $arg =~ /l/; Config::Model::Exception::Any->Trace(1) if $arg =~ /e/; use Log::Log4perl qw(:easy); my $home = $ENV{HOME} || ""; my $log4perl_user_conf_file = "$home/.log4config-model"; if ( $log and -e $log4perl_user_conf_file ) { Log::Log4perl::init($log4perl_user_conf_file); } else { Log::Log4perl->easy_init($WARN); } ok( 1, "Compilation done" ); # pseudo root where config files are written by config-model my $wr_root = path('wr_root'); # cleanup before tests $wr_root->remove_tree; $wr_root->mkpath( { mode => 0755 } ); my $fused = $wr_root->child('fused'); $fused->mkpath( { mode => 0755 } ); my $model = Config::Model->new( legacy => 'ignore' ); $model->load( Master => 't/big_model.pm' ); $model->augment_config_class( name => 'Master', element => [ 'a_boolean' => { type => 'leaf', value_type => 'boolean', default => 0 }, ], ); my $inst = $model->instance( root_class_name => 'Master' ); ok( $inst, "created dummy instance" ); my $root = $inst->config_root; my $step = 'std_id:ab X=Bv - std_id:bc X=Av - std_id:"a/c" X=Av - a_string="toto tata"'; ok( $root->load( step => $step ), "set up data in tree with '$step'" ); my $ui = Config::Model::FuseUI->new( root => $root, mountpoint => "$fused", dir_char_mockup => '\\', ); my $dir_char_mockup = $ui->dir_char_mockup; ok( $ui, "Created ui (dir mockup is $dir_char_mockup)" ); # now fork my $pid = fork; if ( defined $pid and $pid == 0 ) { # child process, just run fuse and wait for exit $ui->run_loop( debug => $fuse_debug ); exit; } # WARNING: the child process has its own copy of the config tree # there's no use in modifying the tree on the parent process. # wait for fuse to do its job sleep 1; # child process, continue tests my @content = sort map { $_->relative($fused); } $fused->children; is_deeply( \@content, [ sort $root->get_element_name() ], "check $fused content" ); my $std_id = $fused->child('std_id'); @content = sort map { $_->relative($std_id); } $std_id->children; my @std_id_elements = sort $root->fetch_element('std_id')->fetch_all_indexes(); map { s(/){$dir_char_mockup}g; } @std_id_elements; is_deeply( \@content, \@std_id_elements, "check $std_id content (@content)" ); is( $fused->child('a_string')->slurp, $root->grab_value('a_string') . "\n", "check a_string content" ); my $a_string_fhw = $fused->child('a_string')->openw; $a_string_fhw->print("foo bar"); $a_string_fhw->close; is( $fused->child('a_string')->slurp, "foo bar\n", "check new a_string content" ); $std_id->child('cd')->mkpath(); ok( 1, "mkpath on cd dir done" ); @content = sort map { $_->relative($std_id); } $std_id->children; is_deeply( \@content, [ @std_id_elements, 'cd' ], "check $std_id new content (@content)" ); $std_id->child('cd')->remove_tree(); ok( 1, "remove_tree on cd dir done" ); @content = sort map { $_->relative($std_id); } $std_id->children; is_deeply( \@content, \@std_id_elements, "check $std_id content after rmdir (@content)" ); is( $fused->child('a_boolean')->slurp, "0\n", "check new a_boolean content" ); my $a_boolean_fhw = $fused->child('a_boolean')->openw; $a_boolean_fhw->print("1"); $a_boolean_fhw->close; is( $fused->child('a_boolean')->slurp, "1\n", "check new a_boolean content (set to 1)" ); $a_boolean_fhw = $fused->child('a_boolean')->openw; $a_boolean_fhw->print("a"); $a_boolean_fhw->close; is( $fused->child('a_boolean')->slurp, "\n", "check new a_boolean content (blank after error)" ); END { if ($pid) { # run this only in parent process # umount so child process will exit system("fusermount -u $fused"); # inspired from perlipc man page my $child; while ( ( $child = wait ) > 0 ) { ok( 1, "Process pid $child done" ); } } exit; } memory_cycle_ok( $model, "memory cycles" ); Config-Model-2.097/t/warped_id.t0000644000175000017500000001610613027007223015026 0ustar domidomi# -*- cperl -*- # $Author$ # $Date$ # $Revision$ use warnings; use ExtUtils::testlib; use Test::More tests => 37; use Test::Memory::Cycle; use Config::Model; use strict; my $arg = shift || ''; my $trace = $arg =~ /t/ ? 1 : 0; Config::Model::Exception::Any->Trace(1) if $arg =~ /e/; use Log::Log4perl qw(:easy); Log::Log4perl->easy_init( $arg =~ /l/ ? $TRACE : $WARN ); ok( 1, "Compilation done" ); # minimal set up to get things working my $model = Config::Model->new( legacy => 'ignore', ); $model->create_config_class( name => 'Slave', element => [ [qw/X Y Z/] => { type => 'leaf', value_type => 'enum', choice => [qw/Av Bv Cv/], } ] ); $model->create_config_class( name => 'Master', 'element' => [ macro => { type => 'leaf', value_type => 'enum', choice => [qw/A B C/], }, version => { type => 'leaf', value_type => 'integer', default => 1 }, warped_hash => { type => 'hash', index_type => 'integer', max_nb => 3, warp => { follow => '- macro', rules => { A => { max_nb => 1 }, B => { max_nb => 2 } } }, cargo_type => 'node', config_class_name => 'Slave' }, 'multi_warp' => { type => 'hash', index_type => 'integer', min => 0, max => 3, default => [ 0 .. 3 ], warp => { follow => [ '- version', '- macro' ], 'rules' => [ [ '2', 'C' ] => { max => 7, default => [ 0 .. 7 ] }, [ '2', 'A' ] => { max => 7, default => [ 0 .. 7 ] } ] }, cargo_type => 'node', config_class_name => 'Slave' }, # how to properly hide bar when macro != A ??? 'hash_with_warped_value' => { type => 'hash', index_type => 'string', cargo_type => 'leaf', level => 'hidden', # must also accept level and description here warp => { follow => '- macro', 'rules' => { 'A' => { level => 'advanced', }, } }, cargo_args => { value_type => 'string', warp => { follow => '- macro', 'rules' => { 'A' => { default => 'dumb string' }, } } } }, 'multi_auto_create' => { type => 'hash', index_type => 'integer', min => 0, max => 3, auto_create => [ 0 .. 3 ], 'warp' => { follow => [ '- version', '- macro' ], 'rules' => [ [ '2', 'C' ] => { max => 7, auto_create_keys => [ 0 .. 7 ] }, [ '2', 'A' ] => { max => 7, auto_create_keys => [ 0 .. 7 ] } ], }, cargo_type => 'node', config_class_name => 'Slave' }, ] ); ok( 1, "compiled" ); my $inst = $model->instance( root_class_name => 'Master', instance_name => 'test1' ); ok( $inst, "created dummy instance" ); my $root = $inst->config_root; my $macro = $root->fetch_element('macro'); is( $root->is_element_available('hash_with_warped_value'), 0, "check warped out hash_with_warped_value (macro is undef)" ); is( $macro->store('A'), 1, "Set macro to A" ); is( $macro->fetch(), 'A', "Check macro" ); is( $root->is_element_available('hash_with_warped_value'), 1, "check warped out hash_with_warped_value (macro is A)" ); my $warped_hash = $root->fetch_element('warped_hash'); ok( $warped_hash->fetch_with_id('1'), "Set one slave" ); my $res = eval { $warped_hash->fetch_with_id('2'); }; ok( $@, "Set second slave (normal error)" ); print "normal error:", $@, "\n" if $trace; is( $macro->store('B'), 1, "Set macro to B" ); ok( $warped_hash->fetch_with_id('2'), "Set second slave" ); $res = eval { $warped_hash->fetch_with_id('3'); }; ok( $@, "Set third slave (normal error)" ); print "normal error:", $@, "\n" if $trace; is( $macro->store('C'), 1, "Set macro to C (warp_reset)" ); ok( $warped_hash->fetch_with_id('3'), "Set third slave" ); $res = eval { $warped_hash->fetch_with_id('4'); }; ok( $@, "Set fourth slave (normal error)" ); print "normal error:", $@, "\n" if $trace; eval { $macro->store('B'); }; ok( $@, "Set macro to B: limit max to 2 when the hash has id '3'" ); print "normal error:", $@, "\n" if $trace; # so remove one item $warped_hash->delete('3'); # and retry is( $macro->store('B'), 1, "Set macro to B (limit max to 2)" ); is_deeply( [ $warped_hash->fetch_all_indexes ], [qw/1 2/], "check reduced key set" ); my $multi_warp = $root->fetch_element('multi_warp'); is( $multi_warp->max_index, 3, "check multi_warp default max_index" ); my $multi_auto_create = $root->fetch_element('multi_auto_create'); is( $multi_auto_create->max_index, 3, "check multi_auto_create default max_index" ); is( $root->fetch_element('version')->store(2), 1, 'set version to 2' ); is( $macro->store('C'), 1, 'set macro to C' ); is_deeply( $multi_warp->default_keys, [ 0 .. 7 ], "check multi_warp default_keys index parameter" ); is_deeply( [ sort $multi_warp->fetch_all_indexes ], [ 0 .. 7 ], "check multi_warp default key set with different warp master" ); is( $multi_warp->fetch_with_id('5')->fetch_element('X')->store('Av'), 1, "store Av in X" ); $root->load( step => 'multi_warp:5 X=Av' ); is( $root->grab_value('multi_warp:5 X'), 'Av', 'check X value' ); is( $multi_warp->max_index, 7, "check multi_warp warped_hash max_index" ); is_deeply( [ sort $multi_auto_create->fetch_all_indexes ], [ 0 .. 7 ], "check multi_auto_create default key set with different warp master" ); $root->load( step => 'multi_auto_create:5 X=Av' ); is( $root->grab_value('multi_auto_create:5 X'), 'Av', "check X value" ); is( $multi_auto_create->max_index, 7, "check multi_auto_create warped_hash max_index" ); # remove one item to avoid error when setting macro to A $warped_hash->delete('2'); is( $root->is_element_available('hash_with_warped_value'), 0, "check warped out hash_with_warped_value (macro is C)" ); ok( $macro->store('A'), "assign new value to warp master (same effect)" ); is( $root->grab_value('multi_warp:5 X'), 'Av', "check X value after assign" ); is( $root->is_element_available('hash_with_warped_value'), 1, "check warped out hash_with_warped_value (macro is A)" ); is( $root->grab_value('hash_with_warped_value:5'), 'dumb string', "check hash_with_warped_value:5" ); is( $root->grab_value('hash_with_warped_value:6'), 'dumb string', "check hash_with_warped_value:6" ); memory_cycle_ok($model); Config-Model-2.097/t/iterator.t0000644000175000017500000001157413027007223014725 0ustar domidomi# -*- cperl -*- use ExtUtils::testlib; use Test::More tests => 33; use Test::Memory::Cycle; use Config::Model; use Config::Model::Value; use Log::Log4perl qw(get_logger :levels); use warnings; no warnings qw(once); use strict; use Data::Dumper; # use Config::Model::ObjTreeScanner; use vars qw/$model/; $model = Config::Model->new( legacy => 'ignore', ); my $arg = shift || ''; my $trace = $arg =~ /t/ ? 1 : 0; my $log = $arg =~ /l/ ? 1 : 0; Config::Model::Exception::Any->Trace(1) if $arg =~ /e/; my $home = $ENV{HOME} || ""; my $log4perl_user_conf_file = "$home/.log4config-model"; if ( $log and -r $log4perl_user_conf_file ) { Log::Log4perl::init($log4perl_user_conf_file); } else { Log::Log4perl->easy_init($WARN); } ok( 1, "compiled" ); my @models = $model->load( Master => 't/big_model.pm' ); is_deeply( \@models, [qw/SubSlave2 SubSlave X_base_class2 X_base_class SlaveZ SlaveY Master/], "check list of model declared in t/big_model.pm (taking order into account)" ); $model->augment_config_class( name => 'Master', element => [ warn_if => { type => 'leaf', value_type => 'string', warn_if_match => { 'foo' => { fix => '$_ = uc;' } }, }, warn_unless => { type => 'leaf', value_type => 'string', warn_unless_match => { foo => { msg => '', fix => '$_ = "foo".$_;' } }, }, ] ); my $inst = $model->instance( root_class_name => 'Master', instance_name => 'test1' ); ok( $inst, "created dummy instance" ); my $root = $inst->config_root; Config::Model::Exception::Any->Trace(1) if $trace =~ /e/; my $step = qq! warn_if=foobar std_id:ab X=Bv - std_id:ab2 - std_id:bc X=Av - std_id:"a b" X=Av - std_id:"a b.c" X=Av - tree_macro=mXY hash_a:toto=toto_value hash_a:titi=titi_value hash_a:"ti ti"="ti ti value" ordered_hash:z=1 ordered_hash:y=2 ordered_hash:x=3 lista=a,b,c,d olist:0 X=Av - olist:1 X=Bv - my_reference="titi" warp warp2 aa2="foo bar" !; $Config::Model::Value::nowarning = 1; ok( $root->load( step => $step ), "set up data in tree" ); my @expected = ( [ '', 'lista' ], [ '', 'lista:0' ], [ 'back', 'lista:1' ], [ '', 'lista:0' ], [ 'for', 'lista' ], [ '', 'lista:0' ], [ '', 'lista:1' ], [ '', 'lista:2' ], [ '', 'lista:3' ], [ '', 'hash_a' ], [ '', 'hash_a:"ti ti"' ], [ '', 'hash_a:titi' ], [ '', 'hash_a:toto' ], [ '', 'tree_macro' ], [ '', 'a_string' ], [ 'back', 'int_v' ], [ '', 'a_string' ], [ '', 'tree_macro' ], [ '', 'hash_a:toto' ], [ 'for', 'hash_a:titi' ], [ '', 'hash_a:toto' ], [ '', 'tree_macro' ], [ '', 'a_string' ], [ '', 'int_v' ], [ 'back', 'warn_if' ], [ 'bail', 'int_v' ], ); my $steer = sub { my ( $iter, $item ) = @_; my ( $dir, $expect ) = @$item; $iter->bail_out if $dir eq 'bail'; $iter->go_forward if $dir eq 'for'; $iter->go_backward if $dir eq 'back'; return @$item; }; my $leaf_element_cb = sub { my ( $iter, $data_r, $node, $element, $index, $leaf_object ) = @_; print "test: leaf_element_cb called for ", $leaf_object->location, "\n" if $trace; my ( $dir, $expect ) = $steer->( $iter, shift @expected ); is( $leaf_object->location, $expect, "leaf_element_cb got $expect and '$dir'" ); }; my $int_cb = sub { my ( $iter, $data_r, $node, $element, $index, $leaf_object ) = @_; print "test: int_cb called for ", $leaf_object->location, "\n" if $trace; my ( $dir, $expect ) = $steer->( $iter, shift @expected ); is( $leaf_object->location, $expect, "int_cb got $expect and '$dir'" ); }; my $hash_element_cb = sub { my ( $iter, $data_r, $node, $element, @keys ) = @_; print "test: hash_element_cb called for ", $node->location, " element $element\n" if $trace; my $obj = $node->fetch_element($element); my ( $dir, $expect ) = $steer->( $iter, shift @expected ); is( $obj->location, $expect, "hash_element_cb got $expect and '$dir'" ); }; my $list_element_cb = sub { my ( $iter, $data_r, $node, $element, @idx ) = @_; print "test: list_element_cb called for ", $node->location, " element $element\n" if $trace; my $obj = $node->fetch_element($element); my ( $dir, $expect ) = $steer->( $iter, shift @expected ); is( $obj->location, $expect, "list_element_cb got $expect and '$dir'" ); }; my $iterator = $inst->iterator( leaf_cb => $leaf_element_cb, integer_value_cb => $int_cb, hash_element_cb => $hash_element_cb, list_element_cb => $list_element_cb, call_back_on_warning => 1, call_back_on_important => 1, ); ok( $iterator, "created iterator helper" ); $iterator->start; is_deeply( \@expected, [], "iterator explored all items" ); memory_cycle_ok($model); Config-Model-2.097/t/augment_class.t0000644000175000017500000001061213027007223015711 0ustar domidomi# -*- cperl -*- use warnings; use ExtUtils::testlib; use Test::More; use Test::Exception; use Test::Memory::Cycle; use Test::Differences; use Config::Model; use Data::Dumper; use Log::Log4perl qw(:easy :levels); use strict; my $arg = shift || ''; my ( $log, $show ) = (0) x 2; my $trace = $arg =~ /t/ ? 1 : 0; $log = 1 if $arg =~ /l/; $show = 1 if $arg =~ /s/; my $home = $ENV{HOME} || ""; my $log4perl_user_conf_file = "$home/.log4config-model"; if ( $log and -e $log4perl_user_conf_file ) { Log::Log4perl::init($log4perl_user_conf_file); } else { Log::Log4perl->easy_init( $log ? $WARN : $ERROR ); } Config::Model::Exception::Any->Trace(1) if $arg =~ /e/; ok( 1, "Compilation done" ); # minimal set up to get things working my $model = Config::Model->new(); $model->create_config_class( name => "Master", accept => [ '.*' => { type => 'leaf', value_type => 'uniline', } ], element => [ one => { type => 'leaf', value_type => 'string', }, 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('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.097/t/big_model.pm0000644000175000017500000001522613027007223015164 0ustar domidomi# -*- cperl -*- # # This file is part of Config-Model # # This software is Copyright (c) 2005-2016 by Dominique Dumont. # # This is free software, licensed under: # # The GNU Lesser General Public License, Version 2.1, February 1999 # # this file is used by test script [ [ name => 'SubSlave2', element => [ [qw/aa2 ab2 ac2 ad2 Z/] => { type => 'leaf', value_type => 'string' } ], description => [ Z => 'Z comme zorro' ], ], [ name => 'SubSlave', element => [ [qw/aa ab ac ad/] => { type => 'leaf', value_type => 'string' }, sub_slave => { type => 'node', config_class_name => 'SubSlave2', } ] ], [ name => 'X_base_class2', element => [ X => { type => 'leaf', value_type => 'enum', choice => [qw/Av Bv Cv/] }, ], class_description => 'rather dummy class to check include feature', ], [ name => 'X_base_class', include => 'X_base_class2', ], [ name => 'SlaveZ', element => [ [qw/Z/] => { type => 'leaf', value_type => 'enum', choice => [qw/Av Bv Cv/] }, [qw/DX/] => { type => 'leaf', value_type => 'enum', default => 'Dv', choice => [qw/Av Bv Cv Dv/] }, ], include => 'X_base_class', include_after => 'Z', ], [ name => 'SlaveY', element => [ std_id => { type => 'hash', index_type => 'string', cargo_type => 'node', config_class_name => 'SlaveZ', }, sub_slave => { type => 'node', config_class_name => 'SubSlave', }, warp2 => { type => 'warped_node', 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', cargo_args => { value_type => 'string' }, }, [qw/hash_a hash_b/] => { type => 'hash', index_type => 'string', cargo_type => 'leaf', cargo_args => { value_type => 'string' }, }, ordered_hash => { type => 'hash', index_type => 'string', ordered => 1, cargo_type => 'leaf', cargo_args => { value_type => 'string' }, }, olist => { type => 'list', cargo_type => 'node', config_class_name => 'SlaveZ', }, tree_macro => { type => 'leaf', value_type => 'enum', choice => [qw/XY XZ mXY/], help => { XY => 'XY help', XZ => 'XZ help', mXY => 'mXY help', } }, warp => { type => 'warped_node', 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', }, 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.097/t/multi_warp_object.t0000644000175000017500000001016613027007223016601 0ustar domidomi# -*- cperl -*- use warnings; use ExtUtils::testlib; use Test::More; use Test::Memory::Cycle; use Config::Model; use strict; my $arg = shift || ''; my $trace = $arg =~ /t/ ? 1 : 0; Config::Model::Exception::Any->Trace(1) if $arg =~ /e/; use Log::Log4perl qw(:easy); Log::Log4perl->easy_init( $arg =~ /l/ ? $TRACE : $WARN ); ok( 1, "Compilation done" ); # minimal set up to get things working my $model = Config::Model->new( legacy => 'ignore', ); $model->create_config_class( name => 'SlaveY', 'element' => [ [qw/X Y/] => { type => 'leaf', value_type => 'enum', choice => [qw/Av Bv Cv/] } ] ); $model->create_config_class( name => 'SlaveZ', element => [ [qw/X Z/] => { type => 'leaf', value_type => 'enum', choice => [qw/Av Bv Cv/] } ] ); $model->create_config_class( name => 'Master', #level => [bar => 'hidden'], 'element' => [ macro1 => { type => 'leaf', value_type => 'enum', choice => [qw/A B/] }, macro2 => { type => 'leaf', value_type => 'enum', choice => [qw/C D/] }, 'bar' => { type => 'hash', index_type => 'string', level => 'hidden', # goes normal when both m1 and m2 are defined 'warp' => { follow => { m1 => '! macro1', m2 => '- macro2' }, 'rules' => [ '$m1 eq "A" and $m2 eq "D"' => { level => 'normal' }, '$m1 and $m2' => { level => 'normal', }, # '$m1 eq "A" and $m2 eq "C"' => { level => 'normal', }, # '$m1 eq "B" and $m2 eq "C"' => { level => 'normal', }, # '$m1 eq "B" and $m2 eq "D"' => { level => 'normal', }, ] }, cargo => { type => 'warped_node', 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); done_testing; Config-Model-2.097/t/pod.t0000644000175000017500000000055613027007223013654 0ustar domidomiBEGIN { unless ( $ENV{AUTHOR_TESTING} ) { require Test::More; Test::More::plan( skip_all => 'these tests are for testing by the author' ); } } use strict; use Test::More; eval "use Test::Pod 1.00"; plan skip_all => "Test::Pod 1.00 required for testing POD" if $@; my @poddirs = qw( lib script ); all_pod_files_ok( all_pod_files(@poddirs) ); Config-Model-2.097/t/auto_load_model.t0000644000175000017500000000247713027007223016225 0ustar domidomi# -*- cperl -*- use ExtUtils::testlib; use Test::More tests => 6; use Test::Memory::Cycle; use Config::Model; use warnings; no warnings qw(once); use strict; my $model = Config::Model->new( legacy => 'ignore', ); my $arg = shift || ''; my $trace = $arg =~ /t/ ? 1 : 0; Config::Model::Exception::Any->Trace(1) if $arg =~ /e/; use Log::Log4perl qw(:easy); Log::Log4perl->easy_init( $arg =~ /l/ ? $TRACE : $WARN ); ok( 1, "compiled" ); my $inst = $model->instance( root_class_name => 'Master', model_file => 't/big_model.pm', instance_name => 'test1' ); ok( $inst, "created dummy instance" ); my $root = $inst->config_root; ok( $root, "Config root created" ); my $step = 'std_id:ab X=Bv - std_id:bc X=Av - a_string="toto tata" ' . 'lista=a,b,c,d olist:0 X=Av - olist:1 X=Bv - listb=b,c,d'; ok( $root->load( step => $step ), "set up data in tree with '$step'" ); # no need to check more. The above command would have failed if # the file containing the model was not loaded. # check that loading a model without inheritance works my $model2 = Config::Model->new( legacy => 'ignore', skip_include => 1 ); my $inst2 = $model2->instance( root_class_name => 'Master', model_file => 't/big_model.pm', instance_name => 'test1' ); ok( $inst2, "created dummy instance 2" ); memory_cycle_ok($model); Config-Model-2.097/t/accept.t0000644000175000017500000001016013027007223014321 0ustar domidomi# -*- cperl -*- use ExtUtils::testlib; use Test::More; use Test::Exception; use Test::Warn; use Test::Memory::Cycle; use Config::Model; use File::Path; use File::Copy; use Data::Dumper; use warnings; no warnings qw(once); use strict; use vars qw/$model/; $model = Config::Model->new(); my $arg = shift || ''; my $trace = $arg =~ /t/ ? 1 : 0; Config::Model::Exception::Any->Trace(1) if $arg =~ /e/; use Log::Log4perl qw(:easy); Log::Log4perl->easy_init( $arg =~ /l/ ? $TRACE : $ERROR ); ok( 1, "compiled" ); $model->create_config_class( name => 'Host', accept => [ 'list.*' => { type => 'list', cargo => { type => 'leaf', value_type => 'string', }, accept_after => 'id', }, 'str.*' => { type => 'leaf', value_type => 'uniline' }, 'bad.*' => { type => 'leaf', value_type => 'uniline', warn => 'gotcha', }, 'ot.*' => { type => 'leaf', value_type => 'uniline', }, #TODO: Some advanced structures, hashes, etc. ], element => [ [qw/id other/] => { type => 'leaf', value_type => 'uniline', }, 'strhidden' => { type => 'leaf', value_type => 'uniline', level => 'hidden', }, ] ); ok( 1, "Created new class with accept parameter" ); # set_up data my $i_hosts = $model->instance( instance_name => 'hosts_inst', root_class_name => 'Host', ); is($model->get_element_property(qw/class Host element otary property value_type/),'uniline', "get_element_property on accepted element" ); is($model->get_element_property(qw/class Host element other property value_type/),'uniline', "get_element_property on a predefined element matching an accepted one" ); # Test fix where XS-Autobuild did show up with cme edit dpkg-control is($model->get_element_property(qw/class Host element strhidden property level/),'hidden', "get_element_property on hidden accepted element" ); is($model->get_element_property(qw/class Host element strok property level/),'normal', "get_element_property on a predefined hidden element matching an accepted one" ); ok( $i_hosts, "Created instance" ); my $i_root = $i_hosts->config_root; is_deeply( [ $i_root->accept_regexp ], [qw/list.* str.* bad.* ot.*/], "check accept_regexp" ); is_deeply( [ $i_root->get_element_name ], [qw/id other/], "check explicit element list" ); is( $i_root->element_type('otary'),'leaf',"check element_type on accepted 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"; } ### test always_warn parameter my $bad = $i_root->fetch_element('badbad'); warning_like { $bad->store('whatever'); } qr/gotcha/, "test unconditional warn"; eval {require Text::Levenshtein::Damerau} ; my $has_tld = ! $@ ; SKIP: { skip "Text::Levenshtein::Damerau is not installed", 5 unless $has_tld; ### test user typo: accepted element is too close to real element my @shaves = qw/oter 1 other2 1 otehr 1 other23 1 oterh23 0/; while ( my $close_shave = shift @shaves) { my $expect = shift @shaves; if ($expect) { warning_like { $i_root->fetch_element($close_shave); } qr/distance/, "test $close_shave too close to 'other'"; } else { warnings_are { $i_root->fetch_element($close_shave); } [], "test accept $close_shave, is not too close to 'other'"; } } } memory_cycle_ok($model); done_testing; Config-Model-2.097/t/model_tests.d/0000755000175000017500000000000013027007223015443 5ustar domidomiConfig-Model-2.097/t/model_tests.d/layer-test-conf.pl0000644000175000017500000000273313027007223021021 0ustar domidomi# # This file is part of Config-Model # # This software is Copyright (c) 2005-2016 by Dominique Dumont. # # This is free software, licensed under: # # The GNU Lesser General Public License, Version 2.1, February 1999 # use Config::Model::BackendMgr; # test loading layered config à la ssh_config $home_for_test = '/home/joe' ; Config::Model::BackendMgr::_set_test_home($home_for_test) ; $model->create_config_class( name => "LayeredClass", element => [ [qw/set_in_etc set_by_user set_in_both/] , { 'value_type' => 'uniline', 'type' => 'leaf', }, 'a_checklist' => { #'default_list' => [ qw/b c/ ], 'type' => 'check_list', 'choice' => [ 'a' .. 'g' ] }, ], 'read_config' => [ { 'backend' => 'perl_file', 'config_dir' => '~/foo', 'file' => 'config.pl', 'default_layer' => { 'config_dir' => '/etc', 'file' => 'foo-config.pl' } } ] ); $model_to_test = "LayeredClass" ; @tests = ( { # t0 name => 'mini', check => [ set_in_etc => {qw/mode layered value /, 'system value'}, set_in_both => {qw/mode layered value /, 'system value2'}, set_in_both => {qw/mode user value /, 'user value2'}, set_by_user => 'user value', a_checklist => {qw/mode layered value /,'c,e'}, a_checklist => 'f,g', a_checklist => {qw/mode user value /, 'c,f,g'}, ] }, ); 1; Config-Model-2.097/t/model_tests.d/backend-json-test-conf.pl0000644000175000017500000000231313027007223022235 0ustar domidomi# # This file is part of Config-Model # # This software is Copyright (c) 2005-2016 by Dominique Dumont. # # This is free software, licensed under: # # The GNU Lesser General Public License, Version 2.1, February 1999 # use Config::Model::BackendMgr; # test shellvar backend $conf_dir = '/etc'; $conf_file_name = 'hosts.json'; $model->create_config_class( name => 'Host', element => [ [qw/ipaddr canonical alias/] => { type => 'leaf', value_type => 'uniline', }, dummy => {qw/type leaf value_type uniline default toto/}, ] ); $model->create_config_class( name => 'Hosts', read_config => [ { backend => 'json', config_dir => '/etc/', file => 'hosts.json', }, ], element => [ record => { type => 'list', cargo => { type => 'node', config_class_name => 'Host', }, }, ] ); $model_to_test = "Hosts"; @tests = ( { name => 'basic', check => [ 'record:0 ipaddr' => '127.0.0.1', 'record:1 canonical' => 'bilbo' ] }, ); 1; Config-Model-2.097/t/model_tests.d/backend-ini-examples/0000755000175000017500000000000013027007223021423 5ustar domidomiConfig-Model-2.097/t/model_tests.d/backend-ini-examples/complex0000644000175000017500000000024213027007223023013 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.097/t/model_tests.d/multistrap-test-conf.pl0000644000175000017500000000360413027007223022107 0ustar domidomi# # This file is part of Config-Model # # This software is Copyright (c) 2005-2016 by Dominique Dumont. # # This is free software, licensed under: # # The GNU Lesser General Public License, Version 2.1, February 1999 # $model_to_test = "Multistrap"; $from_scratch_file = <<'EOF' ; ## This file was written by cme command. ## You can run 'cme edit multistrap' to modify this file. ## You may also modify the content of this file with your favorite editor. [general] include=/usr/share/multistrap/crosschroot.conf EOF @tests = ( { name => 'arm', config_file => '/home/foo/my_arm.conf', check => { 'sections:toolchains packages:0' ,'g++-4.2-arm-linux-gnu', 'sections:toolchains packages:1', 'linux-libc-dev-arm-cross', }, load_warnings => undef , # some weird warnings pop up in Perl smoke tests with perl 5.15.9 }, { name => 'from_scratch', config_file => '/home/foo/my_arm.conf', load => "include=/usr/share/multistrap/crosschroot.conf" , check => { # values brought by included file 'sections:debian packages:0', {qw/mode layered value dpkg-dev/}, 'sections:base packages:0', {qw/mode layered value gcc-4.2-base/}, 'sections:toolchains packages:0', undef, 'sections:toolchains packages:1', undef, }, file_check_sub => sub { my $r = shift ; # this file was created after the load instructions above unshift @$r, "/home/foo/my_arm.conf"; }, file_content => { "/home/foo/my_arm.conf" => $from_scratch_file , } }, { name => 'igep0020', config_file => '/home/foo/strap-igep0020.conf', load_check => 'skip', load_warnings => [ qr/deprecated/, (qr/deprecated/, qr/skipping/) x2 ] }, ); 1; Config-Model-2.097/t/model_tests.d/multi-ini-examples/0000755000175000017500000000000013027007223021166 5ustar domidomiConfig-Model-2.097/t/model_tests.d/multi-ini-examples/max-overflow/0000755000175000017500000000000013027007223023614 5ustar domidomiConfig-Model-2.097/t/model_tests.d/multi-ini-examples/max-overflow/etc/0000755000175000017500000000000013027007223024367 5ustar domidomiConfig-Model-2.097/t/model_tests.d/multi-ini-examples/max-overflow/etc/bar.conf0000644000175000017500000000002013027007223025772 0ustar domidomiint_with_max=100Config-Model-2.097/t/model_tests.d/backend-ini-test-conf.pl0000644000175000017500000000354313027007223022051 0ustar domidomi# # This file is part of Config-Model # # This software is Copyright (c) 2005-2016 by Dominique Dumont. # # This is free software, licensed under: # # The GNU Lesser General Public License, Version 2.1, February 1999 # # test inifile backend # specify where is the example file $conf_file_name = 'test.ini'; $conf_dir = '/etc'; # specify the name of the class to test $model_to_test = "MiniIni"; # create minimal model to test ini file backend. # this class is used by MiniIni class below $model->create_config_class( name => 'IniTest::Class', element => [ [qw/lista listb/] => { type => 'list', cargo => { type => 'leaf', value_type => 'uniline', }, }, ] ); $model->create_config_class( 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' } ], read_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', auto_create => 1, }], ); # the test suite @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" ]''! ] }, ); 1; Config-Model-2.097/t/model_tests.d/fstab-test-conf.pl0000644000175000017500000000155713027007223021007 0ustar domidomi# # This file is part of Config-Model # # This software is Copyright (c) 2005-2016 by Dominique Dumont. # # This is free software, licensed under: # # The GNU Lesser General Public License, Version 2.1, February 1999 # $conf_file_name = "fstab" ; $conf_dir = "etc" ; $model_to_test = "Fstab" ; @tests = ( { # t0 check => { 'fs:/proc fs_spec', "proc" , 'fs:/proc fs_file', "/proc" , 'fs:/home fs_file', "/home", 'fs:/home fs_spec', "UUID=18e71d5c-436a-4b88-aa16-308ebfa2eef8", }, dump_errors => [ qr/value 2 > max limit 0/ => 'fs:"/var/chroot/lenny-i386/dev" fs_passno=0' , ], }, { #t1 check => { 'fs:root fs_spec', "LABEL=root" , 'fs:root fs_file', "/" , }, }, ); 1; Config-Model-2.097/t/model_tests.d/popcon-examples/0000755000175000017500000000000013027007223020555 5ustar domidomiConfig-Model-2.097/t/model_tests.d/popcon-examples/t00000644000175000017500000000041713027007223021025 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.097/t/model_tests.d/backend-shellvar-examples/0000755000175000017500000000000013027007223022464 5ustar domidomiConfig-Model-2.097/t/model_tests.d/backend-shellvar-examples/debian-7192560000644000175000017500000000003213027007223024377 0ustar domidomifoo=ok bar = "with space" Config-Model-2.097/t/model_tests.d/backend-shellvar-test-conf.pl0000644000175000017500000000164513027007223023113 0ustar domidomi# # This file is part of Config-Model # # This software is Copyright (c) 2005-2016 by Dominique Dumont. # # This is free software, licensed under: # # The GNU Lesser General Public License, Version 2.1, February 1999 # use Config::Model::BackendMgr; # test shellvar backend $home_for_test = '/home/joe'; $conf_file_name = 'foo.conf'; $conf_dir = '/etc'; $model->create_config_class( name => "Shelly", element => [ [qw/foo bar/], { 'value_type' => 'uniline', 'type' => 'leaf', }, ], 'read_config' => [ { backend => 'ShellVar', config_dir => '/etc', file => 'foo.conf', } ] ); $model_to_test = "Shelly"; @tests = ( { # mini (test for Debian #719256) name => 'debian-719256', check => [ foo => 'ok', bar => "with space" ] }, ); 1; Config-Model-2.097/t/model_tests.d/layer-examples/0000755000175000017500000000000013027007223020373 5ustar domidomiConfig-Model-2.097/t/model_tests.d/layer-examples/mini/0000755000175000017500000000000013027007223021327 5ustar domidomiConfig-Model-2.097/t/model_tests.d/layer-examples/mini/etc/0000755000175000017500000000000013027007223022102 5ustar domidomiConfig-Model-2.097/t/model_tests.d/layer-examples/mini/etc/foo-config.pl0000644000175000017500000000050513027007223024465 0ustar domidomi# # This file is part of Config-Model # # This software is Copyright (c) 2005-2016 by Dominique Dumont. # # This is free software, licensed under: # # The GNU Lesser General Public License, Version 2.1, February 1999 # { set_in_etc => 'system value', set_in_both => 'system value2', a_checklist => {qw/c 1 d 0 e 1/} }; Config-Model-2.097/t/model_tests.d/layer-examples/mini/home/0000755000175000017500000000000013027007223022257 5ustar domidomiConfig-Model-2.097/t/model_tests.d/layer-examples/mini/home/joe/0000755000175000017500000000000013027007223023034 5ustar domidomiConfig-Model-2.097/t/model_tests.d/layer-examples/mini/home/joe/foo/0000755000175000017500000000000013027007223023617 5ustar domidomiConfig-Model-2.097/t/model_tests.d/layer-examples/mini/home/joe/foo/config.pl0000644000175000017500000000050113027007223025415 0ustar domidomi# # This file is part of Config-Model # # This software is Copyright (c) 2005-2016 by Dominique Dumont. # # This is free software, licensed under: # # The GNU Lesser General Public License, Version 2.1, February 1999 # { set_by_user => 'user value', set_in_both => 'user value2', a_checklist => {qw/e 0 f 1 g 1/} }; Config-Model-2.097/t/model_tests.d/popcon-test-conf.pl0000644000175000017500000000057113027007223021201 0ustar domidomi# # This file is part of Config-Model # # This software is Copyright (c) 2005-2016 by Dominique Dumont. # # This is free software, licensed under: # # The GNU Lesser General Public License, Version 2.1, February 1999 # $conf_file_name = "popularity-contest.conf" ; $conf_dir = "etc" ; $model_to_test = "PopCon" ; @tests = ( { # t0 check => { } }, ); 1; Config-Model-2.097/t/model_tests.d/fstab-examples/0000755000175000017500000000000013027007223020356 5ustar domidomiConfig-Model-2.097/t/model_tests.d/fstab-examples/t00000644000175000017500000000216213027007223020625 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 Config-Model-2.097/t/model_tests.d/fstab-examples/t10000644000175000017500000000322413027007223020626 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.097/t/model_tests.d/backend-json-examples/0000755000175000017500000000000013027007223021615 5ustar domidomiConfig-Model-2.097/t/model_tests.d/backend-json-examples/basic0000644000175000017500000000025213027007223022620 0ustar domidomi{ "record": [ { "ipaddr": "127.0.0.1", "canonical": "localhost", "alias": "localhost" }, { "ipaddr": "192.168.0.1", "canonical": "bilbo" } ] } Config-Model-2.097/t/model_tests.d/multi-ini-test-conf.pl0000644000175000017500000000341513027007223021612 0ustar domidomi# # This file is part of Config-Model # # This software is Copyright (c) 2005-2016 by Dominique Dumont. # # This is free software, licensed under: # # The GNU Lesser General Public License, Version 2.1, February 1999 # # test inifile backend with multiple ini files # specify the name of the class to test $model_to_test = "MultiMiniIni"; # create minimal model to test ini file backend. # this class is used by MultiMiniIni class below $model->create_config_class( name => 'MultiIniTest::Class', element => [ int_with_max => {qw/type leaf value_type integer max 10/}, ], read_config => [{ backend => 'IniFile', config_dir => '/etc/', file => '&index.conf', auto_create => 1, }], ); $model->create_config_class( 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' } }, ], read_config => [{ backend => 'Yaml', config_dir => '/etc/', file => 'service.yml', auto_create => 1, }], ); # the test suite @tests = ( { name => 'max-overflow', # 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.yml" ; }, }, ); 1; Config-Model-2.097/t/model_tests.d/multistrap-examples/0000755000175000017500000000000013027007223021463 5ustar domidomiConfig-Model-2.097/t/model_tests.d/multistrap-examples/from_scratch/0000755000175000017500000000000013027007223024135 5ustar domidomiConfig-Model-2.097/t/model_tests.d/multistrap-examples/from_scratch/usr/0000755000175000017500000000000013027007223024746 5ustar domidomiConfig-Model-2.097/t/model_tests.d/multistrap-examples/from_scratch/usr/share/0000755000175000017500000000000013027007223026050 5ustar domidomiConfig-Model-2.097/t/model_tests.d/multistrap-examples/from_scratch/usr/share/multistrap/0000755000175000017500000000000013027007223030254 5ustar domidomi././@LongLink0000644000000000000000000000015200000000000011601 Lustar rootrootConfig-Model-2.097/t/model_tests.d/multistrap-examples/from_scratch/usr/share/multistrap/crosschroot.confConfig-Model-2.097/t/model_tests.d/multistrap-examples/from_scratch/usr/share/multistrap/crosschroot0000644000175000017500000000210413027007223032544 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.097/t/model_tests.d/multistrap-examples/igep0020/0000755000175000017500000000000013027007223022711 5ustar domidomiConfig-Model-2.097/t/model_tests.d/multistrap-examples/igep0020/usr/0000755000175000017500000000000013027007223023522 5ustar domidomiConfig-Model-2.097/t/model_tests.d/multistrap-examples/igep0020/usr/share/0000755000175000017500000000000013027007223024624 5ustar domidomiConfig-Model-2.097/t/model_tests.d/multistrap-examples/igep0020/usr/share/multistrap/0000755000175000017500000000000013027007223027030 5ustar domidomi././@LongLink0000644000000000000000000000014600000000000011604 Lustar rootrootConfig-Model-2.097/t/model_tests.d/multistrap-examples/igep0020/usr/share/multistrap/crosschroot.confConfig-Model-2.097/t/model_tests.d/multistrap-examples/igep0020/usr/share/multistrap/crosschroot.con0000644000175000017500000000210413027007223032076 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.097/t/model_tests.d/multistrap-examples/igep0020/usr/share/multistrap/squeeze.conf0000644000175000017500000000140313027007223031356 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.097/t/model_tests.d/multistrap-examples/igep0020/usr/share/multistrap/arm.conf0000644000175000017500000000042213027007223030454 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.097/t/model_tests.d/multistrap-examples/igep0020/home/0000755000175000017500000000000013027007223023641 5ustar domidomiConfig-Model-2.097/t/model_tests.d/multistrap-examples/igep0020/home/foo/0000755000175000017500000000000013027007223024424 5ustar domidomiConfig-Model-2.097/t/model_tests.d/multistrap-examples/igep0020/home/foo/strap-igep0020.conf0000644000175000017500000000063313027007223027652 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.097/t/model_tests.d/multistrap-examples/arm/0000755000175000017500000000000013027007223022242 5ustar domidomiConfig-Model-2.097/t/model_tests.d/multistrap-examples/arm/usr/0000755000175000017500000000000013027007223023053 5ustar domidomiConfig-Model-2.097/t/model_tests.d/multistrap-examples/arm/usr/share/0000755000175000017500000000000013027007223024155 5ustar domidomiConfig-Model-2.097/t/model_tests.d/multistrap-examples/arm/usr/share/multistrap/0000755000175000017500000000000013027007223026361 5ustar domidomiConfig-Model-2.097/t/model_tests.d/multistrap-examples/arm/usr/share/multistrap/crosschroot.conf0000644000175000017500000000210413027007223031575 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.097/t/model_tests.d/multistrap-examples/arm/home/0000755000175000017500000000000013027007223023172 5ustar domidomiConfig-Model-2.097/t/model_tests.d/multistrap-examples/arm/home/foo/0000755000175000017500000000000013027007223023755 5ustar domidomiConfig-Model-2.097/t/model_tests.d/multistrap-examples/arm/home/foo/my_arm.conf0000644000175000017500000000042213027007223026106 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.097/t/hash_id_of_values.t0000644000175000017500000003770713027007223016544 0ustar domidomi# -*- cperl -*- use warnings; use ExtUtils::testlib; use Test::More ; use Test::Memory::Cycle; use Config::Model; use Test::Exception; use Test::Warn; use Test::Differences; use strict; my $arg = shift || ''; my $trace = $arg =~ /t/ ? 1 : 0; Config::Model::Exception::Any->Trace(1) if $arg =~ /e/; use Log::Log4perl qw(:easy); Log::Log4perl->easy_init( $arg =~ /l/ ? $TRACE : $WARN ); ok( 1, "Compilation done" ); # new parameter style my @element = ( # Value constructor args are passed in their specific array ref cargo => { type => 'leaf', value_type => 'string', class => 'Config::Model::Value', }, ); # minimal set up to get things working my $model = Config::Model->new( ); $model->create_config_class( name => "Master", element => [ plain_hash => { type => 'hash', index_type => 'integer', cargo => { type => 'leaf', value_type => 'string' }, }, bounded_hash => { type => 'hash', class => 'Config::Model::HashId', # default index_type => 'integer', # hash boundaries min => 1, max => 123, max_nb => 2, @element }, hash_with_auto_created_id => { type => 'hash', index_type => 'string', auto_create_keys => ['yada'], @element }, hash_with_several_auto_created_id => { type => 'hash', index_type => 'string', auto_create_keys => [qw/x y z/], @element }, [qw/hash_with_default_id hash_with_default_id_2/] => { type => 'hash', index_type => 'string', default_keys => ['yada'], @element }, hash_with_several_default_keys => { type => 'hash', index_type => 'string', default_keys => [qw/x y z/], @element }, hash_follower => { type => 'hash', index_type => 'string', @element, follow_keys_from => '- hash_with_several_auto_created_id', }, hash_with_allow => { type => 'hash', index_type => 'string', @element, allow_keys => [qw/foo bar baz/], }, hash_with_allow_from => { type => 'hash', index_type => 'string', @element, allow_keys_from => '- hash_with_several_auto_created_id', }, hash_with_allow_keys_matching => { type => 'hash', index_type => 'string', @element, allow_keys_matching => '^foo\d{2}$', }, hash_with_follow_keys_from => { type => 'hash', index_type => 'string', @element, follow_keys_from => '- hash_with_several_auto_created_id', }, hash_with_migrate_keys_from => { type => 'hash', index_type => 'string', @element, migrate_keys_from => '- hash_with_several_auto_created_id', }, hash_with_follow_keys_from_unknown => { type => 'hash', index_type => 'string', @element, follow_keys_from => '- unknown_hash', }, ordered_hash => { type => 'hash', index_type => 'string', @element, ordered => 1, }, hash_with_warn_if_key_match => { type => 'hash', index_type => 'string', @element, warn_if_key_match => 'foo', }, hash_with_warn_unless_key_match => { type => 'hash', index_type => 'string', @element, warn_unless_key_match => 'foo', }, hash_with_default_and_init => { type => 'hash', index_type => 'string', default_with_init => { 'def_1' => 'def_1 stuff', 'def_2' => 'def_2 stuff' }, @element }, hash_with_convert_lc => { type => 'hash', index_type => 'string', convert => 'lc', @element }, ], ); my $inst = $model->instance( root_class_name => 'Master', instance_name => 'test1' ); ok( $inst, "created dummy instance" ); my $root = $inst->config_root; $inst->initial_load_stop; is( $inst->needs_save, 0, "verify instance needs_save status after creation" ); my $b = $root->fetch_element('bounded_hash'); ok( $b, "bounded hash created" ); is( $b->get_cargo_type, 'leaf', 'check get_cargo_type' ); is( $b->get_cargo_info('value_type'), 'string', 'check get_cargo_info' ); is( $b->name, 'Master bounded_hash id', "check hash id name" ); my $b1 = $b->fetch_with_id(1); isa_ok( $b1, 'Config::Model::Value', "fetched element id 1" ); is( $inst->needs_save, 0, "verify instance needs_save status after element creation" ); is( $b1->store('foo'), 1, "Storing in id 1" ); is( $inst->needs_save, 1, "verify instance needs_save status after storing into element" ); is( $b->fetch_with_id(2)->store('bar'), 1, "Storing in id 2" ); is( $inst->needs_save, 2, "verify instance needs_save status after storing into another element" ); print scalar $inst->list_changes, "\n" if $trace; eval { $b->fetch_with_id('')->store('foo'); }; ok( $@, "empty index error" ); print "normal error: ", $@ if $trace; eval { $b->fetch_with_id(0)->store('foo'); }; ok( $@, "min error" ); print "normal error: ", $@ if $trace; eval { $b->fetch_with_id(124)->store('foo'); }; ok( $@, "max error" ); print "normal error: ", $@ if $trace; eval { $b->fetch_with_id(40)->store('foo'); }; ok( $@, "max nb error" ); print "normal error: ", $@ if $trace; is( $inst->needs_save, 2, "verify instance needs_save status after store errors" ); print scalar $inst->list_changes, "\n" if $trace; $inst->clear_changes; ok( $b->delete(2), "delete id 2" ); is( $b->exists(2), '', "deleted id does not exist" ); is( $inst->needs_save, 1, "verify instance needs_save status after delete" ); print scalar $inst->list_changes, "\n" if $trace; $inst->clear_changes; is( $b->index_type, 'integer', "reading value_type" ); is( $b->max_index, 123, "reading max boundary" ); my $ac = $root->fetch_element('hash_with_auto_created_id'); ok( $ac, "created hash_with_auto_created_id" ); eq_or_diff( [ $ac->fetch_all_indexes ], ['yada'], "check auto-created id" ); ok( $ac->exists('yada'), "...idem" ); $ac->fetch_with_id('foo')->store(3); ok( $ac->exists('yada'), "...idem after creating another id" ); eq_or_diff( [ $ac->fetch_all_indexes ], [ 'foo', 'yada' ], "check the 2 ids" ); my $dk = $root->fetch_element('hash_with_default_id'); ok( $dk, "created hash_with_default_id ..." ); eq_or_diff( [ $dk->fetch_all_indexes ], ['yada'], "check default id" ); ok( $dk->exists('yada'), "...and test default id on empty hash" ); my $dk2 = $root->fetch_element('hash_with_default_id_2'); ok( $dk2, "created hash_with_default_id_2 ..." ); ok( $dk2->fetch_with_id('foo')->store(3), "... store a value..." ); eq_or_diff( [ $dk2->fetch_all_indexes ], ['foo'], "...check existing id..." ); is( $dk2->exists('yada'), '', "...and test that default id is not provided" ); my $dk3 = $root->fetch_element('hash_with_several_default_keys'); ok( $dk3, "created hash_with_several_default_keys ..." ); eq_or_diff( [ sort $dk3->fetch_all_indexes ], [qw/x y z/], "...check default id" ); my $ac2 = $root->fetch_element('hash_with_several_auto_created_id'); ok( $ac2, "created hash_with_several_auto_created_id ..." ); ok( $ac2->fetch_with_id('foo')->store(3), "... store a value..." ); eq_or_diff( [ sort $ac2->fetch_all_indexes ], [qw/foo x y z/], "...check id..." ); my $follower = $root->fetch_element('hash_follower'); eq_or_diff( [ sort $follower->fetch_all_indexes ], [qw/foo x y z/], "check follower id" ); eval { $follower->fetch_with_id('zoo')->store('zoo'); }; ok( $@, "forbidden index error (not in followed object)" ); print "normal error: ", $@ if $trace; my $allow = $root->fetch_element('hash_with_allow'); ok( $allow, "created hash_with_allow ..." ); ok( $allow->fetch_with_id('foo')->store(3), "... store a value..." ); eval { $allow->fetch_with_id('zoo')->store('zoo'); }; ok( $@, "not allowed index error" ); print "normal error: ", $@ if $trace; my $allow_from = $root->fetch_element('hash_with_allow_from'); ok( $allow_from, "created hash_with_allow ..." ); ok( $allow_from->fetch_with_id('foo')->store(3), "... store a value..." ); eval { $allow_from->fetch_with_id('zoo')->store('zoo'); }; ok( $@, "not allowed index error" ); print "normal error: ", $@ if $trace; print scalar $inst->list_changes, "\n" if $trace; $inst->clear_changes; my $ph = $root->fetch_element('plain_hash'); $ph->fetch_with_id(2)->store('baz'); ok( $ph->copy( 2, 3 ), "value copy" ); is( $ph->fetch_with_id(3)->fetch, $ph->fetch_with_id(2)->fetch, "compare copied value" ); print scalar $inst->list_changes, "\n" if $trace; $inst->clear_changes; my $hwfkf = $root->fetch_element('hash_with_follow_keys_from'); ok( $hwfkf, "created hash_with_follow_keys_from ..." ); eq_or_diff( [ $hwfkf->get_default_keys ], [qw/foo x y z/], 'check default keys of hash_with_follow_keys_from' ); my $hwfkfu = $root->fetch_element('hash_with_follow_keys_from_unknown'); ok( $hwfkfu, "created hash_with_follow_keys_from_unknown ..." ); eval { $hwfkfu->get_default_keys; }; ok( $@, "failed to get keys from hash_with_follow_keys_from_unknown" ); print "normal error: $@" if $trace; my $oh = $root->fetch_element('ordered_hash'); ok( $oh, "created ordered_hash ..." ); $oh->fetch_with_id('z')->store('1z'); $oh->fetch_with_id('x')->store('2x'); $oh->fetch_with_id('a')->store('3a'); eq_or_diff( [ $oh->fetch_all_indexes ], [qw/z x a/], "check index order of ordered_hash" ); $inst->clear_changes; $oh->swap(qw/z x/); is( $inst->needs_save, 1, "verify instance needs_save status after swap" ); print scalar $inst->list_changes, "\n" if $trace; $inst->clear_changes; eq_or_diff( [ $oh->fetch_all_indexes ], [qw/x z a/], "check index order of ordered_hash after swap(z x)" ); $oh->swap(qw/a z/); eq_or_diff( [ $oh->fetch_all_indexes ], [qw/x a z/], "check index order of ordered_hash after swap(a z)" ); $inst->clear_changes; $oh->move_up(qw/a/); is( $inst->needs_save, 1, "verify instance needs_save status after move_up" ); print scalar $inst->list_changes, "\n" if $trace; $inst->clear_changes; eq_or_diff( [ $oh->fetch_all_indexes ], [qw/a x z/], "check index order of ordered_hash after move_up(a)" ); $oh->move_down(qw/x/); is( $inst->needs_save, 1, "verify instance needs_save status after move_down" ); print scalar $inst->list_changes, "\n" if $trace; $inst->clear_changes; eq_or_diff( [ $oh->fetch_all_indexes ], [qw/a z x/], "check index order of ordered_hash after move_down(x)" ); is( $oh->fetch_with_id('x')->fetch, '2x', "Check copied value" ); $oh->copy(qw/x d/); is( $inst->needs_save, 1, "verify instance needs_save status after copy" ); print scalar $inst->list_changes, "\n" if $trace; $inst->clear_changes; eq_or_diff( [ $oh->fetch_all_indexes ], [qw/a z x d/], "check index order of ordered_hash after copy(x d)" ); is( $oh->fetch_with_id('d')->fetch, '2x', "Check copied value" ); $oh->copy(qw/a e/); eq_or_diff( [ $oh->fetch_all_indexes ], [qw/a z x d e/], "check index order of ordered_hash after copy(a e)" ); is( $oh->fetch_with_id('e')->fetch, '3a', "Check copied value" ); $inst->clear_changes; $oh->move_after('d'); eq_or_diff( [ $oh->fetch_all_indexes ], [qw/d a z x e/], "check index order of ordered_hash after move_after(d)" ); is( $inst->needs_save, 1, "verify instance needs_save status after move_after" ); print scalar $inst->list_changes, "\n" if $trace; $inst->clear_changes; $oh->move_after( 'd', 'z' ); eq_or_diff( [ $oh->fetch_all_indexes ], [qw/a z d x e/], "check index order of ordered_hash after move_after(d z)" ); is( $inst->needs_save, 1, "verify instance needs_save status after move_after" ); print scalar $inst->list_changes, "\n" if $trace; $inst->clear_changes; $oh->move_after( 'd', 'e' ); eq_or_diff( [ $oh->fetch_all_indexes ], [qw/a z x e d/], "check index order of ordered_hash after move_after(d e)" ); $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" ); $oh->clear; $oh->load_data( { __order => [qw/a b c d e/], qw/a va b vb c vc d vd e ve/ } ); eq_or_diff( [ $oh->fetch_all_indexes ], [qw/a b c d e/], "check index order of ordered_hash loaded with hash and __order" ); $oh->move( 'e', 'e2' ); eq_or_diff( [ $oh->fetch_all_indexes ], [qw/a b c d e2/], "check index order of ordered_hash after move(e e2)" ); my $v = $oh->fetch_with_id('e2')->fetch; is( $v, 've', "Check moved value" ); $oh->move( 'd', 'e2' ); eq_or_diff( [ $oh->fetch_all_indexes ], [qw/a b c e2/], "check index order of ordered_hash after move(d e2)" ); $v = $oh->fetch_with_id('e2')->fetch; is( $v, 'vd', "Check moved value" ); $oh->move( 'b', 'd' ); eq_or_diff( [ $oh->fetch_all_indexes ], [qw/a d c e2/], "check index order of ordered_hash after move(b d)" ); $v = $oh->fetch_with_id('d')->fetch; is( $v, 'vb', "Check moved value" ); $oh->move( 'c', 'a' ); eq_or_diff( [ $oh->fetch_all_indexes ], [qw/d a e2/], "check index order of ordered_hash after move(c a)" ); $v = $oh->fetch_with_id('a')->fetch; is( $v, 'vc', "Check moved value" ); my $hwakm = $root->fetch_element('hash_with_allow_keys_matching'); throws_ok { $hwakm->fetch_with_id('bar2'); } 'Config::Model::Exception::WrongValue', "check not matching key"; ok( $hwakm->fetch_with_id('foo22'), "check matching key" ); # test warnings with keys my $hwwikm = $root->fetch_element('hash_with_warn_if_key_match'); warning_like { $hwwikm->fetch_with_id('foo2'); } qr/key 'foo2' should not match/, "warn if matching key"; warning_like { $hwwikm->fetch_with_id("foo2 multi\nline\nid"); } qr/key 'foo2 multi\[\.\.\.\]' should not match/, "warn if matching multi_line key"; my $hwwukm = $root->fetch_element('hash_with_warn_unless_key_match'); warning_like { $hwwukm->fetch_with_id('bar2'); } qr/key 'bar2' should match foo/, "warn unless matching key"; # test key migration my $hwmkf = $root->fetch_element('hash_with_migrate_keys_from'); my @to_migrate = $root->fetch_element('hash_with_several_auto_created_id')->fetch_all_indexes; eq_or_diff( [ $hwmkf->fetch_all_indexes ], \@to_migrate, "check ids of hash_with_migrate_keys_from" ); my $hwdai = $root->fetch_element('hash_with_default_and_init'); # calling fetch_all_indexes will trigger the creation of the default_with_init keys foreach ( $hwdai->fetch_all_indexes ) { is( $hwdai->fetch_with_id($_)->fetch, "$_ stuff", "check default_with_init with $_" ); } # test convert lc my $hwclc = $root->fetch_element('hash_with_convert_lc'); $hwclc->fetch_with_id('Debian')->store('DebV'); $hwclc->fetch_with_id('Grip')->store('GripV'); eq_or_diff( [ $hwclc->fetch_all_indexes ], [qw/debian grip/], "check converted ids" ); memory_cycle_ok( $model, "check memory cycles" ); done_testing; Config-Model-2.097/t/test_yaml_model.pl0000644000175000017500000000323013027007223016413 0ustar domidomi# # This file is part of Config-Model # # This software is Copyright (c) 2005-2016 by Dominique Dumont. # # This is free software, licensed under: # # The GNU Lesser General Public License, Version 2.1, February 1999 # # test model used by t/*.t my @backend_config = ( read_config => [{ backend => 'yaml', config_dir => '/yaml/', file => 'hosts.yml', auto_create => 1, full_dump => 0, auto_delete => 1, }], ); [ { name => 'Host', element => [ [qw/ipaddr canonical alias/] => { type => 'leaf', value_type => 'uniline', }, dummy => {qw/type leaf value_type uniline default toto/}, ] }, { name => 'Hosts', @backend_config, element => [ record => { type => 'list', cargo => { type => 'node', config_class_name => 'Host', }, }, ] }, { name => 'SingleHashElement', @backend_config, element => [ record => { type => 'hash', index_type => 'string', cargo => { type => 'node', config_class_name => 'Host', }, }, ] }, { name => 'TwoElements', include => 'SingleHashElement', @backend_config, element => [ foo => { type => 'leaf', value_type => 'uniline', } ] } ]; Config-Model-2.097/t/array_id.t0000644000175000017500000003604213027007223014663 0ustar domidomi# -*- cperl -*- use warnings; use ExtUtils::testlib; use Test::More; use Test::Exception; use Test::Warn; use Test::Differences; use Test::Memory::Cycle; use Config::Model; use Config::Model::AnyId; use Log::Log4perl qw(:easy :levels); use strict; my $arg = shift || ''; my $log = 0; my $trace = $arg =~ /t/ ? 1 : 0; $log = 1 if $arg =~ /l/; my $home = $ENV{HOME} || ""; my $log4perl_user_conf_file = "$home/.log4config-model"; if ( $log and -e $log4perl_user_conf_file ) { Log::Log4perl::init($log4perl_user_conf_file); } else { Log::Log4perl->easy_init( $log ? $WARN : $ERROR ); } my $model = Config::Model->new(); Config::Model::Exception::Any->Trace(1) if $arg =~ /e/; ok( 1, "compiled" ); my @element = ( # Value constructor args are passed in their specific array ref cargo => { type => 'leaf', value_type => 'string' }, ); # minimal set up to get things working $model->create_config_class( name => "Master", element => [ bounded_list => { type => 'list', class => 'Config::Model::ListId', # default max => 123, cargo => { type => 'leaf', value_type => 'string' }, }, plain_list => { type => 'list', @element }, list_with_auto_created_id => { type => 'list', auto_create_ids => 4, @element }, olist => { type => 'list', cargo => { type => 'node', config_class_name => 'Slave' }, }, list_with_default_with_init_leaf => { type => 'list', default_with_init => { 0 => 'def_1 stuff', 1 => 'def_2 stuff' }, @element, }, list_with_default_with_init_node => { type => 'list', default_with_init => { 0 => 'X=Bv Y=Cv', 1 => 'X=Av' }, cargo => { type => 'node', config_class_name => 'Slave' }, }, map { ( "list_with_" . $_ . "_duplicates" => { type => 'list', duplicates => $_, @element, }, ); } qw/warn allow forbid suppress/, ] ); $model->create_config_class( name => "Bogus", element => [ list_with_wrong_auto_create => { type => 'list', auto_create_ids => ['foo'], @element }, list_with_wrong_duplicates => { type => 'list', duplicates => 'forbid', cargo => { type => 'node', config_class_name => 'Slave' }, }, list_with_yada_duplicates => { type => 'list', duplicates => 'yada', @element, }, ] ); $model->create_config_class( name => "Slave", element => [ [qw/X Y Z/] => { type => 'leaf', value_type => 'enum', choice => [qw/Av Bv Cv/] }, ] ); ok( 1, "config classes created" ); my $inst = $model->instance( root_class_name => 'Master', instance_name => 'test1' ); ok( $inst, "created dummy instance" ); $inst->initial_load_stop; my $root = $inst->config_root; 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" ); my $b = $root->fetch_element('bounded_list'); ok( $b, "bounded list created" ); is( $inst->needs_save, 0, "verify instance needs_save status after element creation" ); is( $b->fetch_with_id(1)->store('foo'), 1, "stored in 1" ); is( $b->fetch_with_id(0)->store('baz'), 1, "stored in 0" ); is( $b->fetch_with_id(2)->store('bar'), 1, "stored in 2" ); is( $inst->needs_save, 3, "verify instance needs_save status after storing into element" ); print join( "\n", $inst->list_changes("\n") ), "\n" if $trace; throws_ok { $b->fetch_with_id(124)->store('baz'); } qr/Index 124 > max_index limit 123/, 'max error caught'; my $bogus_root = $model->instance( root_class_name => 'Bogus' )->config_root; throws_ok { $bogus_root->fetch_element('list_with_wrong_auto_create'); } qr/Wrong auto_create argument for list/, 'wrong auto_create caught'; eq_or_diff( [ $b->fetch_all_indexes ], [ 0, 1, 2 ], "check ids" ); $b->delete(1); is( $b->fetch_with_id(1)->fetch, undef, "check deleted id" ); is( $b->index_type, 'integer', 'check list index_type' ); is( $b->max_index, 123, 'check list max boundary' ); $b->push( 'toto', 'titi' ); is( $b->fetch_with_id(2)->fetch, 'bar', "check last item of table" ); is( $b->fetch_with_id(3)->fetch, 'toto', "check pushed toto item" ); is( $b->fetch_with_id(4)->fetch, 'titi', "check pushed titi item" ); $b->push_x( values => [ 'toto', 'titi' ], check => 'no', annotation => ['toto comment'] ); is( $b->fetch_with_id(5)->fetch, 'toto', "check pushed toto item with push_x" ); is( $b->fetch_with_id(5)->annotation, 'toto comment', "check pushed toto annotation with push_x" ); is( $b->fetch_with_id(6)->fetch, 'titi', "check pushed titi item with push_x" ); $b->push_x( values => 'toto2', check => 'no', annotation => 'toto2 comment' ); is( $b->fetch_with_id(7)->fetch, 'toto2', "check pushed toto2 item with push_x" ); is( $b->fetch_with_id(7)->annotation, 'toto2 comment', "check pushed toto2 annotation with push_x" ); my @all = $b->fetch_all_values; eq_or_diff( \@all, [qw/baz bar toto titi toto titi toto2/], "check fetch_all_values" ); my $lac = $root->fetch_element('list_with_auto_created_id'); eq_or_diff( [ $lac->fetch_all_indexes ], [ 0 .. 3 ], "check list_with_auto_created_id" ); map { is( $b->fetch_with_id($_)->index_value, $_, "Check index value $_" ); } ( 0 .. 4 ); $b->move( 3, 4 ); is( $b->fetch_with_id(3)->fetch, undef, "check after move idx 3 in 4" ); is( $b->fetch_with_id(4)->fetch, 'toto', "check after move idx 3 in 4" ); map { is( $b->fetch_with_id($_)->index_value, $_, "Check moved index value $_" ); } ( 0 .. 4 ); $b->fetch_with_id(3)->store('titi'); $b->swap( 3, 4 ); map { is( $b->fetch_with_id($_)->index_value, $_, "Check swapped index value $_" ); } ( 0 .. 4 ); is( $b->fetch_with_id(3)->fetch, 'toto', "check value after swap" ); is( $b->fetch_with_id(4)->fetch, 'titi', "check value after swap" ); $b->remove(3); is( $b->fetch_with_id(3)->fetch, 'titi', "check after remove" ); # test move swap with node list my $ol = $root->fetch_element('olist'); my @set = ( [qw/X Av/], [qw/X Bv/], [qw/Y Av/], [qw/Z Cv/], [qw/Z Av/], ); my $i = 0; foreach my $item (@set) { my ( $e, $v ) = @$item; $ol->fetch_with_id( $i++ )->fetch_element($e)->store($v); } $inst->clear_changes; $ol->move( 3, 4 ); is( $inst->needs_save, 1, "verify instance needs_save status after move" ); print scalar $inst->list_changes, "\n" if $trace; $inst->clear_changes; is( $ol->fetch_with_id(3)->fetch_element('Z')->fetch, undef, "check after move idx 3 in 4" ); is( $ol->fetch_with_id(4)->fetch_element('Z')->fetch, 'Cv', "check after move idx 3 in 4" ); map { is( $ol->fetch_with_id($_)->index_value, $_, "Check moved index value $_" ); } ( 0 .. 4 ); $ol->swap( 0, 2 ); is( $inst->needs_save, 1, "verify instance needs_save status after move" ); print scalar $inst->list_changes, "\n" if $trace; $inst->clear_changes; is( $ol->fetch_with_id(0)->fetch_element('X')->fetch, undef, "check after move idx 0 in 2" ); is( $ol->fetch_with_id(0)->fetch_element('Y')->fetch, 'Av', "check after move" ); is( $ol->fetch_with_id(2)->fetch_element('Y')->fetch, undef, "check after move" ); is( $ol->fetch_with_id(2)->fetch_element('X')->fetch, 'Av', "check after move" ); map { is( $ol->fetch_with_id($_)->index_value, $_, "Check moved index value $_" ); } ( 0 .. 4 ); print $root->dump_tree( ) if $trace; is( $ol->fetch_with_id(0)->fetch_element('X')->fetch, undef, "check before move" ); $ol->remove(0); print $root->dump_tree( ) if $trace; is( $ol->fetch_with_id(0)->fetch_element('X')->fetch, 'Bv', "check after move" ); # test store my @test = ( [ a1 => ['a1'] ], [ '"a","b"' => [qw/a b/] ], [ 'a,b' => [qw/a b/] ], [ '"a\"a",b' => [qw/a"a b/] ], [ '"a,a",b' => [ 'a,a', 'b' ] ], [ '",a1"' => [',a1'] ], ); foreach my $l (@test) { $b->load( $l->[0] ); eq_or_diff( [ $b->fetch_all_values ], $l->[1], "test store $l->[0]" ); } throws_ok { $b->load('a,,b'); } "Config::Model::Exception::Load", "fails load 'a,,b'"; # test preset mode $inst->preset_start; my $pl = $root->fetch_element('plain_list'); $pl->fetch_with_id(0)->store('prefoo'); $pl->fetch_with_id(1)->store('prebar'); $inst->preset_stop; ok( 1, "filled preset values" ); eq_or_diff( [ $pl->fetch_all_values ], [ 'prefoo', 'prebar' ], "check that preset values are read" ); $pl->fetch_with_id(2)->store('bar'); eq_or_diff( [ $pl->fetch_all_values ], [ 'prefoo', 'prebar', 'bar' ], "check that values are read" ); eq_or_diff( [ $pl->fetch_all_values( mode => 'custom' ) ], ['bar'], "check that custom values are read" ); # test default_with_init on leaf my $lwdwil = $root->fetch_element('list_with_default_with_init_leaf'); # note: calling fetch_all_indexes is required to trigger creation of default_with_init keys eq_or_diff( [ $lwdwil->fetch_all_indexes ], [ 0, 1 ], "check default keys" ); is( $lwdwil->fetch_with_id(0)->fetch, 'def_1 stuff', "test default_with_init leaf 0" ); is( $lwdwil->fetch_with_id(1)->fetch, 'def_2 stuff', "test default_with_init leaf 1" ); # test default_with_init on node my $lwdwin = $root->fetch_element('list_with_default_with_init_node'); eq_or_diff( [ $lwdwin->fetch_all_indexes ], [ 0, 1 ], "check default keys" ); is( $lwdwin->fetch_with_id(0)->fetch_element('X')->fetch, 'Bv', "test default_with_init node 0" ); is( $lwdwin->fetch_with_id(0)->fetch_element('Y')->fetch, 'Cv', "test default_with_init node 0" ); is( $lwdwin->fetch_with_id(1)->fetch_element('X')->fetch, 'Av', "test default_with_init node 0" ); throws_ok { $bogus_root->fetch_element('list_with_wrong_duplicates'); } "Config::Model::Exception::Model", "fails duplicates with node cargo"; throws_ok { $bogus_root->fetch_element('list_with_yada_duplicates'); } "Config::Model::Exception::Model", "fails yada duplicates"; foreach my $what (qw/forbid warn suppress/) { my $lwd = $root->fetch_element( 'list_with_' . $what . '_duplicates' ); $lwd->push(qw/string1 string2/); $lwd->push('string1'); # does not trigger duplicate issues, yet $lwd->push('string1'); # does not trigger duplicate issues, yet # there we go if ( $what eq 'forbid' ) { is( $lwd->needs_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' ) { warnings_like { $lwd->fetch_all_values; } qr/Duplicated/, "warns with duplicated values"; is ( $lwd->has_warning, 1, "detected duplicated values"); is( $lwd->has_fixes, 2, "check nb of fixes" ); $inst->apply_fixes; warnings_like { $lwd->fetch_all_values; }[], # no warning accepted "no longer warns with duplicated values"; } else { $lwd->check_content; } is( $lwd->fetch_with_id(0)->fetch, 'string1', "check that original values is untouched after $what duplicates" ); } $inst->clear_changes; $pl->clear; is( $inst->needs_save, 1, "verify instance needs_save status after clear array" ); eq_or_diff( [ $pl->fetch_all_indexes ], [], "check that array was cleared" ); eq_or_diff([$inst->list_changes],['plain_list: cleared all entries'],"check change message after clear"); # test preset clear stuff # done after auto_create_ids tests, because preset_clear or layered_clear # also clean up auto_create_ids (if there's no data in there) $inst->preset_start; $pl->fetch_with_id(0)->store('prefoo'); $pl->fetch_with_id(1)->store('prebar'); $inst->preset_stop; eq_or_diff( [ $pl->fetch_all_indexes ], [ 0, 1 ], "check preset indexes" ); $pl->fetch_with_id(1)->store('bar'); $inst->preset_clear; eq_or_diff( [ $pl->fetch_all_indexes ], [0], "check that only preset stuff was cleared" ); is( $pl->fetch_with_id(0)->fetch, 'bar', "check that bar was moved from 1 to 0" ); # test layered stuff $pl->clear; $inst->layered_start; $pl->fetch_with_id(0)->store('prefoo'); $pl->fetch_with_id(1)->store('prebar'); $inst->layered_stop; eq_or_diff( [ $pl->fetch_all_indexes ], [ 0, 1 ], "check layered indexes" ); $pl->fetch_with_id(1)->store('bar'); $inst->layered_clear; eq_or_diff( [ $pl->fetch_all_indexes ], [0], "check that only layered stuff was cleared" ); is( $pl->fetch_with_id(0)->fetch, 'bar', "check that bar was moved from 1 to 0" ); $pl->clear; # test notify change after implicit deletion (github #4) $pl->store_set(qw/j h g f k l/); $inst->clear_changes; @set = qw/j h g f/; $pl->store_set(@set); is( $inst->c_count, 2, "check that store smaller set triggered a change" ); $inst->clear_changes; # test sort $pl->sort; eq_or_diff( [ $pl->fetch_all_values ], [ sort @set ], "check sort result" ); is( $inst->c_count, 1, "check that sort has triggered a change" ); $pl->sort; is( $inst->c_count, 1, "check that redundant sort has not triggered a change" ); # test unshift @set = qw/j h g f/; $pl->store_set(qw/a b/); $pl->unshift(qw/1 2 3 4/); eq_or_diff( [ $pl->fetch_all_values ], [qw/1 2 3 4 a b/], "check unshift result" ); eq_or_diff( [ $pl->fetch_all_indexes ], [ ( 0 .. 5 ) ], "check that indexes are reset correctly" ); # test insert_at $pl->store_set(qw/a b/); $pl->insert_at(qw/1 d e/); eq_or_diff( [ $pl->fetch_all_values ], [qw/a d e b/], "check insert_at result" ); eq_or_diff( [ $pl->fetch_all_indexes ], [ ( 0 .. 3 ) ], "check that indexes are reset correctly" ); # test insert_before $pl->store_set(qw/foo baz/); $pl->insert_before(qw/baz bar1 bar2/); eq_or_diff( [ $pl->fetch_all_values ], [qw/foo bar1 bar2 baz/], "check insert_before result" ); $pl->insert_before( qr/z/, qw/bar3 bar4/ ); eq_or_diff( [ $pl->fetch_all_values ], [qw/foo bar1 bar2 bar3 bar4 baz/], "check insert_before with regexp result" ); # test insort my @set1 = qw/c1 e i1 j1 p1/; my @set2 = qw/a2 z2 d2 e b2 k2/; $pl->store_set(@set1); $pl->sort; $pl->insort(@set2); eq_or_diff( [ $pl->fetch_all_values ], [ sort( @set1, @set2 ) ], "check insort result" ); memory_cycle_ok( $model, "memory cycles" ); done_testing; Config-Model-2.097/t/recursive_warp_value.t0000644000175000017500000000670513027007223017330 0ustar domidomi# -*- cperl -*- # $Author$ # $Date$ # $Revision$ use warnings; use ExtUtils::testlib; use Test::More tests => 21; use Test::Memory::Cycle; use Config::Model; use strict; my $arg = shift || ''; my $trace = $arg =~ /t/ ? 1 : 0; Config::Model::Exception::Any->Trace(1) if $arg =~ /e/; use Log::Log4perl qw(:easy); Log::Log4perl->easy_init( $arg =~ /l/ ? $TRACE : $WARN ); ok( 1, "Compilation done" ); # minimal set up to get things working my $model = Config::Model->new( legacy => 'ignore', ); $model->create_config_class( name => 'Master', 'element' => [ macro => { type => 'leaf', value_type => 'enum', choice => [qw/A B C/] }, m1 => { type => 'leaf', value_type => 'string', warp => { follow => '- macro', rules => [ A => { default => 'm1_A' }, B => { default => 'm1_B' }, C => { default => 'm1_C' } ] } }, compute => { type => 'leaf', value_type => 'string', compute => [ 'macro is $m, my slot is &slot', 'm' => '! macro' ] }, # second level warp (kinda recursive and scary ...) m2a => { type => 'leaf', value_type => 'string', warp => { follow => '- m1', rules => [ m1_A => { default => 'm2a_A' }, m1_B => { default => 'm2a_B' }, m1_C => { default => 'm2a_C' } ] } }, # second level warp (kinda recursive and scary ...) m2b => { type => 'leaf', value_type => 'string', warp => { follow => '- m1', rules => [ m1_A => { default => 'm2b_A' }, m1_B => { default => 'm2b_B' }, m1_C => { default => 'm2b_C' } ] } }, e1 => { type => 'leaf', value_type => 'enum', 'warp' => { follow => '- macro', 'rules' => [ A => { choice => [qw/e1_A e1_B/], default => 'e1_A' }, B => { choice => [qw/e1_B e1_C/], default => 'e1_B' }, C => { choice => [qw/e1_C e1_D/], default => 'e1_C' } ] } }, e2 => { type => 'leaf', value_type => 'string', warp => { follow => '- e1', rules => [ e1_A => { default => 'e2_A' }, e1_B => { default => 'e2_B' }, e1_C => { default => 'e2_C' } ] } }, ], ); my $inst = $model->instance( root_class_name => 'Master', instance_name => 'test1' ); ok( $inst, "created dummy instance" ); my $root = $inst->config_root; foreach my $mv (qw/A B C/) { ok( $root->fetch_element('macro')->store($mv), "Set macro to $mv" ); foreach my $element (qw/m1 m2a m2b/) { is( $root->fetch_element($element)->fetch(), $element . '_' . $mv, "Reading Master element $element" ); } foreach my $element (qw/e1 e2/) { is( $root->fetch_element($element)->fetch(), $element . '_' . $mv, "Reading Master element $element" ); } } memory_cycle_ok($model); Config-Model-2.097/t/warped_node.t0000644000175000017500000001755213027007223015365 0ustar domidomi# -*- cperl -*- use warnings ; use ExtUtils::testlib; use Test::More; use Test::Differences; use Test::Memory::Cycle; use Config::Model; use Log::Log4perl qw(:easy); use strict; my ( $log, $show ) = (0) x 3; my $arg = shift || ''; my $trace = $arg =~ /t/ ? 1 : 0; $log = 1 if $arg =~ /l/; $show = 1 if $arg =~ /s/; Config::Model::Exception::Any->Trace(1) if $arg =~ /e/; my $home = $ENV{HOME} || ""; my $log4perl_user_conf_file = "$home/.log4config-model"; if ( $log and -e $log4perl_user_conf_file ) { Log::Log4perl::init($log4perl_user_conf_file); } else { Log::Log4perl->easy_init( $arg =~ /l/ ? $DEBUG : $WARN ); } ok( 1, "Compilation done" ); # minimal set up to get things working my $model = Config::Model->new( legacy => 'ignore', ); $model->create_config_class( name => 'SlaveY', element => [ [qw/X Y/] => { type => 'leaf', value_type => 'enum', choice => [qw/Av Bv Cv/], warp => { follow => '- - v_macro', rules => { A => { default => 'Av' }, B => { default => 'Bv' } } } }, [qw/a_string a_long_string another_string/] => { type => 'leaf', mandatory => 1, value_type => 'string' }, ] ); $model->create_config_class( name => 'SlaveZ', element => [ [qw/X Z/] => { type => 'leaf', value_type => 'enum', choice => [qw/Av Bv Cv/], warp => { follow => '! v_macro', rules => { A => { default => 'Av' }, B => { default => 'Bv' } } } } ] ); $model->create_config_class( name => 'Master', element => [ v_macro => { type => 'leaf', value_type => 'enum', choice => [qw/A B/] }, b_macro => { type => 'leaf', value_type => 'boolean' }, tree_macro => { type => 'leaf', value_type => 'enum', choice => [qw/XY XZ mXY W AR/] }, 'a_hash_of_warped_nodes' => { type => 'hash', index_type => 'string', level => 'hidden', warp => { follow => '! tree_macro', rules => { XY => { level => 'normal', }, mXY => { level => 'normal', }, XZ => { level => 'normal', }, } }, cargo => { type => 'warped_node', 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' } } } }, 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" ); my $root = $inst->config_root; my $tm = $root->fetch_element('tree_macro'); $tm->store('AR'); is( $root->is_element_available('a_warped_node'), 0, 'check that a_warped_node is not accessible' ); is( $root->is_element_available('a_hash_of_warped_nodes'), 0, 'check that a_hash_of_warped_nodes is not available' ); eval { $root->fetch_element('a_hash_of_warped_nodes')->fetch_with_id(1)->fetch_element('X') ->store('coucou'); }; ok( $@, 'test stored on a warped node element (should fail)' ); print "Normal error:\n", $@ if $trace; is( $root->fetch_element('tree_macro')->store('XY'), 1, 'set master->tree_macro to XY' ); is( $root->fetch_element('a_warped_node')->is_accessible, 1, 'check that a_warped_node is accessible' ); my $ahown = $root->fetch_element('a_hash_of_warped_nodes'); is( $ahown->fetch_with_id(234)->config_class_name, 'SlaveY', "reading a_hash_of_warped_nodes (is SlaveY because tree_macro was set)" ); is( $root->fetch_element('tree_macro')->store('XZ'), 1, 'set master->tree_macro to XZ' ); is( $ahown->fetch_with_id(234)->config_class_name, 'SlaveZ', "reading a_hash_of_warped_nodes (is SlaveZ because tree_macro was set)" ); is( $ahown->fetch_with_id(234)->fetch_element('X')->fetch, undef, 'reading master a_hash_of_warped_nodes:234 X (undef)' ); is( $root->fetch_element('v_macro')->store('A'), 1, 'set master v_macro to A' ); map { is( $ahown->fetch_with_id(234)->fetch_element($_)->fetch, 'Av', "reading master a_hash_of_warped_nodes:234 $_ (default value)" ); } qw/X Z/; map { is( $ahown->fetch_with_id(234)->fetch_element($_)->store('Cv'), 1, "Set master a_hash_of_warped_nodes:234 $_ to Cv" ); } qw/X Z/; is( $root->fetch_element('tree_macro')->store('mXY'), 1, 'set master->tree_macro to mXY (with morphing which looses Z element)...' ); is( $ahown->fetch_with_id(234)->fetch_element('X')->fetch, 'Cv', "... X value was kept ..." ); is( $ahown->fetch_with_id(234)->fetch_element('Y')->fetch, 'Av', "... Y is back to default value" ); is( $root->fetch_element('v_macro')->store('B'), 1, 'set master v_macro to B' ); is( $ahown->fetch_with_id(234)->fetch_element('X')->fetch, 'Cv', "... X value was kept ..." ); is( $ahown->fetch_with_id(234)->fetch_element('Y')->fetch, 'Bv', "... Y is to new default value" ); # TBD #print "Testing dump on warped object\n" if $trace; #my $dump = cute_dump( object => $master ); #ok( $dump, qr/ X = Cv/ ); my $warped_node = $root->fetch_element('a_warped_node'); isa_ok( $warped_node, "Config::Model::WarpedNode", "created warped node" ); is( $ahown->fetch_with_id(234)->element_name, 'a_hash_of_warped_nodes', 'Check element name of warped node' ); is( $ahown->fetch_with_id(234)->index_value, '234', 'Check index value of warped node' ); # should also check that info was passed to actual node below (data # element) is( $ahown->fetch_with_id(234)->element_name, 'a_hash_of_warped_nodes', 'Check element name of actual node below warped node' ); is( $ahown->fetch_with_id(234)->index_value, '234', 'Check index value of actual node below warped node' ); $ahown->copy( 234, 2345 ); print $root->dump_tree( check => 'no' ) if $trace; is( $ahown->fetch_with_id(234)->fetch_element_value('X'), $ahown->fetch_with_id(2345)->fetch_element_value('X'), "check that has copy works on warped_node" ); is( $root->fetch_element('tree_macro')->store('W'), 1, 'set master->tree_macro to W (warp out)...' ); eq_or_diff( [ $root->get_element_name() ], [qw/v_macro b_macro tree_macro/], 'reading elements of root after warp out' ); eq_or_diff( [ $root->get_element_name() ], [qw/v_macro b_macro tree_macro/], 'reading elements of root after warp out' ); is( $root->fetch_element('b_macro')->store(1), 1, 'set master->b_macro to 1 (warp in bool_object)...' ); $root->fetch_element('b_macro')->store(1); is( $root->fetch_element('bool_object')->config_class_name, 'SlaveY', 'check theorical bool_object type...' ); memory_cycle_ok( $model, "mem cycle test" ); done_testing; Config-Model-2.097/t/load.t0000644000175000017500000004772113027007223014016 0ustar domidomi# -*- cperl -*- use ExtUtils::testlib; use Test::More; use Test::Exception; use Test::Differences; use Test::Memory::Cycle; use Config::Model; use Data::Dumper; use Log::Log4perl qw(:easy :levels); use warnings; no warnings qw(once); use strict; my $model = Config::Model->new( legacy => 'ignore', ); my $arg = shift || ''; my ( $log, $show ) = (0) x 2; my $trace = $arg =~ /t/ ? 1 : 0; $log = 1 if $arg =~ /l/; $show = 1 if $arg =~ /s/; my $home = $ENV{HOME} || ""; my $log4perl_user_conf_file = "$home/.log4config-model"; if ( $log and -e $log4perl_user_conf_file ) { Log::Log4perl::init($log4perl_user_conf_file); } else { Log::Log4perl->easy_init( $log ? $WARN : $ERROR ); } Config::Model::Exception::Any->Trace(1) if $arg =~ /e/; # See caveats in Test::More doc my $builder = Test::More->builder; binmode $builder->output, ":utf8"; binmode $builder->failure_output, ":utf8"; binmode $builder->todo_output, ":utf8"; ok( 1, "compiled" ); # test mega regexp, 'x' means undef my @regexp_test = ( # id_operation leaf_operation # string elt op (param) id op val note [ 'a', [ 'a', 'x', 'x', 'x', 'x', 'x', 'x' ] ], [ '#C', [ 'x', 'x', 'x', 'x', 'x', 'x', 'C' ] ], [ '#"m C"', [ 'x', 'x', 'x', 'x', 'x', 'x', '"m C"' ] ], [ 'a=b', [ 'a', 'x', 'x', 'x', '=', 'b', 'x' ] ], [ 'a-z=b', [ 'a-z', 'x', 'x', 'x', '=', 'b', 'x' ] ], [ "a=\x{263A}", [ 'a', 'x', 'x', 'x', '=', "\x{263A}", 'x' ] ], # utf8 smiley [ 'a.=b', [ 'a', 'x', 'x', 'x', '.=', 'b', 'x' ] ], [ "a.=\x{263A}", [ 'a', 'x', 'x', 'x', '.=', "\x{263A}", 'x' ] ], # utf8 smiley [ 'a="b=c"', [ 'a', 'x', 'x', 'x', '=', '"b=c"', 'x' ] ], [ 'a="b=\"c\""', [ 'a', 'x', 'x', 'x', '=', '"b=\"c\""', 'x' ] ], [ 'a=~/a/A/', [ 'a', 'x', 'x', 'x', '=~', '/a/A/', 'x' ] ], # subst on value [ 'a=b#B', [ 'a', 'x', 'x', 'x', '=', 'b', 'B' ] ], [ 'a#B', [ 'a', 'x', 'x', 'x', 'x', 'x', 'B' ] ], [ 'a#"b=c"', [ 'a', 'x', 'x', 'x', 'x', 'x', '"b=c"' ] ], # string elt op (param) id op val note [ 'a:b=c', [ 'a', ':', 'x', 'b', '=', 'c', 'x' ] ], # fetch and assign elt [ 'a:"b\""="\"c"', [ 'a', ':', 'x', '"b\""', '=', '"\"c"', 'x' ] ] , # fetch and assign elt qith quotes [ 'a:~', [ 'a', ':~', 'x', 'x', 'x', 'x', 'x' ] ], # loop on matched value [ 'a:~.=b', [ 'a', ':~', 'x', 'x', '.=', 'b', 'x' ] ], # loop on matched value [ 'a:~/b.*/', [ 'a', ':~', 'x', '/b.*/', 'x', 'x', 'x' ] ], # loop on matched value [ 'a:~"b.*"', [ 'a', ':~', 'x', '"b.*"', 'x', 'x', 'x' ] ], # loop on matched value [ 'a:~/b.*/.="\"a"', [ 'a', ':~', 'x', '/b.*/', '.=', '"\"a"', 'x' ] ], # loop on matched value and append [ 'a:~"b.*".="\"a"', [ 'a', ':~', 'x', '"b.*"', '.=', '"\"a"', 'x' ] ], # loop on matched value and append [ 'a:~/^\w+$/', [ 'a', ':~', 'x', '/^\w+$/', 'x', 'x', 'x' ] ], # loop on matched value [ 'a:="dod@foo.com"', [ 'a', ':=', 'x', '"dod@foo.com"', 'x', 'x', 'x' ] ], # set list [ 'a:=b,c,d', [ 'a', ':=', 'x', 'b,c,d', 'x', 'x', 'x' ] ], # set list [ 'a=b,c,d', [ 'a', 'x', 'x', 'x', '=', 'b,c,d', 'x' ] ], # set list old style [ 'm:=a,"a b "', [ 'm', ':=', 'x', 'a,"a b "', 'x', 'x', 'x' ] ], # set list with quotes [ 'm:="a b ",c', [ 'm', ':=', 'x', '"a b ",c', 'x', 'x', 'x' ] ], # set list with quotes [ 'm:="a b","c d"', [ 'm', ':=', 'x', '"a b","c d"', 'x', 'x', 'x' ] ], # set list with quotes [ 'm=a,"a b "', [ 'm', 'x', 'x', 'x', '=', 'a,"a b "', 'x' ] ] , # set list with quotes, old style [ 'a:b#C', [ 'a', ':', 'x', 'b', 'x', 'x', 'C' ] ], # fetch elt and add comment [ 'a:"b\""#"\"c"', [ 'a', ':', 'x', '"b\""', 'x', 'x', '"\"c"' ] ] , # fetch elt and add comment with quotes [ 'a:b=c#C', [ 'a', ':', 'x', 'b', '=', 'c', 'C' ] ], # fetch and assign elt and add comment [ 'a:-', [ 'a', ':-', 'x', 'x', 'x', 'x', 'x' ] ], # empty list [ 'a:-b', [ 'a', ':-', 'x', 'b', 'x', 'x', 'x' ] ], # remove id b [ 'a:-=b', [ 'a', ':-=', 'x', 'b', 'x', 'x', 'x' ] ], # remove value b from list or hash [ 'a:-~/b/', [ 'a', ':-~', 'x', '/b/', 'x', 'x', 'x' ] ], # remove value matching stuff [ 'a:=~s/b/c/g', [ 'a', ':=~', 'x', 's/b/c/g', 'x', 'x', 'x' ] ] , # subsitute value value matching stuff [ 'a:@', [ 'a', ':@', 'x', 'x', 'x', 'x', 'x' ] ], # sort list [ 'a:.b', [ 'a', ':.b', 'x', 'x', 'x', 'x', 'x' ] ], # function called on elt [ 'a:.b(foo)', [ 'a', ':.b', 'foo', 'x', 'x', 'x', 'x' ] ], # idem with param [ 'a:c', [ 'a', ':>', 'x', 'c', 'x', 'x', 'x' ] ], # unshift value [ 'a:b b)")', [ 'a', ':.b', '"foo(a > b)"', 'x', 'x', 'x', 'x' ] ], # tricky value with () ); foreach my $subtest (@regexp_test) { my ( $cmd, $ref ) = @$subtest; my $res = Config::Model::Loader::_split_cmd($cmd); #print Dumper $res,"\n"; foreach (@$res) { $_ = 'x' unless defined $_; } eq_or_diff( $res, $ref, "test _split_cmd with '$cmd'" ); } my $inst = $model->instance( root_class_name => 'Master', model_file => 't/dump_load_model.pm', instance_name => 'test1' ); ok( $inst, "created dummy instance" ); my $root = $inst->config_root; # check with embedded \n my $step = qq!#"root cooment " std_id:ab X=Bv -\na_string="titi and\nfoo" !; ok( $root->load( step => $step ), "load steps with embedded \\n" ); is( $root->fetch_element('a_string')->fetch, "titi and\nfoo", "check a_string" ); # check with embedded \n and \\n $step = q!a_string="titi and\nfoo and \\\\n literal" !; ok( $root->load( step => $step ), 'load steps with embedded \n and \\n' ); is( $root->fetch_element('a_string')->fetch, "titi and\nfoo and \\n literal", "check a_string" ); # check search up for element $step = qq!std_id:ab X=Bv /a_string="titi and\ntoto" !; ok( $root->load( step => $step ), "load steps with /a_string" ); is( $root->fetch_element('a_string')->fetch, "titi and\ntoto", "check a_string found with search" ); $step = qq!a_string:toto!; # should blow up throws_ok { $root->load( step => $step ) ; } qr/f/, "use ':' on a leaf"; # test apply regexp $step = qq!a_string=~s/TOTO/tata/i!; ok( $root->load( step => $step ), "load steps with apply regexp" ); is( $root->fetch_element('a_string')->fetch, qq!titi and\ntata!, "check a_string after regexp" ); # test apply regexp with embedded spaces $step = qq!a_string=~"s/titi and\n//""!; ok( $root->load( step => $step ), "load steps with apply regexp with embedded spaces" ); is( $root->fetch_element('a_string')->fetch, qq!tata!, "check a_string after regexp with embedded spaces" ); # check with embedded quotes $step = qq!std_id:ab X=Bv -\na_string="\"titi\" and \"toto\"" std_id:bc X=Av!; ok( $root->load( step => $step ), "load steps with embedded quotes" ); is( $root->fetch_element('a_string')->fetch, qq!"titi" and "toto"!, "check a_string with embedded quotes" ); # check with embedded utf8 $step = qq!#"root cooment \x{263A} " std_id:\x{263A} X=Bv -\na_string="titi and\ntoto and \x{263A}" !; ok( $root->load( step => $step ), "load steps with embedded \x{263A}" ); is( $root->fetch_element('a_string')->fetch, "titi and\ntoto and \x{263A}", "check a_string" ); is( $root->fetch_element('std_id')->fetch_with_id("\x{263A}")->fetch_element_value('X'), 'Bv', "check hash with utf8 index" ); # check with embedded literal \n that are switched with real \n # note: using q and not qq $step = q!std_id:"long\nkey" X=Bv - a_string="titi and\ntoto" !; ok( $root->load( step => $step ), 'load steps with embedded \n' ); # now double quote for real \n is( $root->fetch_element('a_string')->fetch, "titi and\ntoto", 'check a_string with embedded \n' ); is( $root->fetch_element('std_id')->fetch_with_id("long\nkey")->fetch_element_value('X'), 'Bv', 'check hash with index with embedded \n' ); $step = 'std_id:ab X=Bv - std_id:bc X=Av - a_string="titi , toto" '; ok( $root->load( step => $step ), "load '$step'" ); is( $root->fetch_element('a_string')->fetch, 'titi , toto', "check a_string" ); # check that we can go to root node starting from below my $stdab = $root->grab("std_id:ab"); $stdab->load("! a_string=titi"); ok( 1, "go to root node starting from below" ); ok( $root->load( step => 'tree_macro=XZ' ), "Set tree_macro to XZ" ); # test load with warped_node below root (used to fail) $step = 'slave_y warp2 aa2="foo bar baz"'; ok( $root->load( step => $step ), "load '$step'" ); # this will warp out slave_y warp2 ok( $root->load( step => 'tree_macro=XY' ), "Set tree_macro to XY" ); # use indexes with white spaces $step = 'std_id:"a b" X=Bv - std_id:" b c " X=Av " '; ok( $root->load( step => $step ), "load '$step'" ); is_deeply( [ $root->fetch_element('std_id')->fetch_all_indexes ], [ ' b c ', 'a b', 'ab', 'bc', "long\nkey", "\x{263A}" ], "check indexes" ); $step = 'std_id:ab ZZX=Bv - std_id:bc X=Bv'; throws_ok { $root->load( step => $step ); } "Config::Model::Exception::UnknownElement", "load wrong '$step'"; $step = 'lista:=a,b,c,d lista:4=e olist:0 X=Av - olist:1 X=Bv - listb:=b,c,d,,f,"",h,0'; throws_ok { $root->load( step => $step ); } qr/comma/, "load wrong '$step'"; $step = 'listb:=b,c,d,f,"",h,0 listc:="dod@foo.com"'; ok( $root->load( step => $step ), "load '$step'" ); # perform some checks my $olist = $root->fetch_element('olist'); is( $olist->fetch_with_id(0)->element_name, 'olist', 'check list element_name' ); map { is( $olist->fetch_with_id($_)->config_class_name, 'SlaveZ', "check list element $_ class" ); } ( 0, 1 ); my $lista = $root->fetch_element('lista'); isa_ok( $lista, 'Config::Model::ListId', 'check lista class' ); map { isa_ok( $lista->fetch_with_id($_), 'Config::Model::Value', "check lista element $_ class" ); } ( 0, 1 ); is( $olist->fetch_with_id(0)->fetch_element('X')->fetch, 'Av', "check list element 0 content" ); is( $olist->fetch_with_id(1)->fetch_element('X')->fetch, 'Bv', "check list element 1 content" ); my @expect = qw/a b c d e/; map { is( $lista->fetch_with_id($_)->fetch, $expect[$_], "check lista element $_ content" ); } ( 0 .. $#expect ); my $listb = $root->fetch_element('listb'); @expect = ( qw/b c d/, 'f', '', 'h', '0' ); map { is( $listb->fetch_with_id($_)->fetch, $expect[$_], "check listb element $_ content" ); } ( 0 .. $#expect ); $step = 'a_string="foo bar"'; ok( $root->load( step => $step, ), "load quoted string: '$step'" ); is( $root->fetch_element('a_string')->fetch, "foo bar", 'check result' ); $step = 'a_string="foo bar baz" lista:=a,b,c,d,e'; ok( $root->load( step => $step, ), "load : '$step'" ); is( $root->fetch_element('a_string')->fetch, "foo bar baz", 'check result' ); @expect = qw/a b c d e/; map { is( $lista->fetch_with_id($_)->fetch, $expect[$_], "check lista element $_ content" ); } ( 0 .. 4 ); # set the value of the previous object $step = 'std_id:"f/o/o:b.ar" X=Bv'; ok( $root->load( step => $step, ), "load : '$step'" ); eq_or_diff( [ sort $root->fetch_element('std_id')->fetch_all_indexes ], [ ' b c ', 'a b', qw!ab bc f/o/o:b.ar!, "long\nkey", "\x{263A}" ], "check result after load '$step'" ); $step = 'hash_a:a=z hash_a:b=z2 hash_a:"a b "="z 1"'; ok( $root->load( step => $step, ), "load : '$step'" ); is_deeply( [ sort $root->fetch_element('hash_a')->fetch_all_indexes ], [ 'a', 'a b ', 'b' ], "check result after load '$step'" ); is( $root->fetch_element('hash_a')->fetch_with_id('a')->fetch, 'z', 'check result' ); my $elt = $root->fetch_element('hash_a')->fetch_with_id('a b '); is( $elt->fetch, 'z 1', 'check result with white spaces' ); is( $elt->location, 'hash_a:"a b "', 'check location' ); $step = 'my_check_list=a,"a b "'; ok( $root->load( step => $step, ), "load : '$step'" ); $step = 'a_string="a \"b\" "'; ok( $root->load( step => $step, ), "load : '$step'" ); is( $root->fetch_element('a_string')->fetch, 'a "b" ', "test value loaded by '$step'" ); $step = 'lista:=a,"a \"b\" "'; ok( $root->load( step => $step, ), "load : '$step'" ); is( $lista->fetch_with_id(1)->fetch, 'a "b" ', "test value loaded by '$step'" ); # test that lista~a complains about non numeric index $step = 'lista~a'; throws_ok { $root->load( step => $step ); } "Config::Model::Exception::User", "load wrong '$step'"; # use new and old notation $step = 'lista:-1 hash_a~"a b "'; ok( $root->load( step => $step, ), "load : '$step'" ); is( $lista->fetch_with_id(1)->fetch, undef, "test list value loaded by '$step'" ); $elt = $root->fetch_element('hash_a')->fetch_with_id('a b '); is( $elt->fetch, undef, "test hash value loaded by '$step'" ); # test append mode $root->load('a_string.=c'); is( $root->fetch_element_value('a_string'), 'a "b" c', "test append on list" ); # test append mode with utf8 $root->load("a_string.=\x{263A}"); is( $root->fetch_element_value('a_string'), 'a "b" c' . "\x{263A}", "test append on list with utf8" ); $root->load('lista:0.=" b c"'); is( $lista->fetch_with_id(0)->fetch,, 'a b c', "test append on leaf" ); $root->load('hash_a:b.=" z3"'); is( $root->fetch_element('hash_a')->fetch_with_id('b')->fetch,, 'z2 z3', "test append on hash" ); # test loop mode $root->load('std_id:~ DX=Av - int_v=9'); is( $root->grab_value('std_id:ab DX'), 'Av', "check looped assign 1" ); is( $root->grab_value('std_id:bc DX'), 'Av', "check looped assign 2" ); is( $root->grab_value('std_id:"a b" DX'), 'Av', "check looped assign 3" ); $root->load('std_id:~/^\w+$/ DX=Bv - int_v=9'); is( $root->grab_value('std_id:ab DX'), 'Bv', "check looped assign 1" ); is( $root->grab_value('std_id:bc DX'), 'Bv', "check looped assign 2" ); is( $root->grab_value('std_id:"a b" DX'), 'Av', "check out of loop left alone" ); # test annotation setting my @anno_test = ( 'std_id', 'std_id:ab', 'lista', 'lista:0', ); foreach my $path (@anno_test) { $root->load(qq!$path#"$path annotation"!); is( $root->grab($path)->annotation, "$path annotation", "fetch $path annotation" ); } # test remove by value and remove by matched value $root->load('lista:=a,b,c,d,foo lista:-=b lista:-~/oo/'); eq_or_diff( [ $lista->fetch_all_values ], [qw/a c d/], "removed value from list" ); # test remove by value and remove by matched value $root->load('lista:=Foo1,foo2,bar lista:=~s/foo/doh/i'); eq_or_diff( [ $lista->fetch_all_values ], [qw/doh1 doh2 bar/], "test :=~ on list" ); $root->load('hash_a:a=Foo3 hash_a:b=foo4 hash_a:c=bar hash_a:=~s/foo/doh/i'); eq_or_diff( [ sort $root->fetch_element('hash_a')->fetch_all_values ], [qw/bar doh3 doh4/], "test :=~ on hash" ); $root->load('lista:=j,h,g,f lista:@'); eq_or_diff( [ $lista->fetch_all_values ], [qw/f g h j/], "test :@ on list" ); $root->load('lista:=j,h,g,f lista:.sort'); eq_or_diff( [ $lista->fetch_all_values ], [qw/f g h j/], "test :.sort on list" ); $root->load('lista:=a,b lista:.push(c) lista:fetch_all_values ], [qw/a b c d/], "test push on list" ); $root->load('lista:=a,b lista:.unshift(1) lista:>2'); eq_or_diff( [ $lista->fetch_all_values ], [qw/2 1 a b/], "test unshift on list" ); # test insert_before $root->load('lista=foo,baz lista:.insert_before(baz,bar1,bar2)'); eq_or_diff( [ $lista->fetch_all_values ], [qw/foo bar1 bar2 baz/], "check insert_before result" ); $root->load('lista:.insert_before(/z/,bar3,bar4)'); eq_or_diff( [ $lista->fetch_all_values ], [qw/foo bar1 bar2 bar3 bar4 baz/], "check insert_before with regexp /z/" ); $root->load('lista:.insert_before(/1/,"bar0a bar0b, bar0c")'); eq_or_diff( [ $lista->fetch_all_values ], [ foo => "bar0a bar0b, bar0c", qw/bar1 bar2 bar3 bar4 baz/ ], "check insert_before with regexp /1/" ); # test insort my @set1 = qw/c1 e i1 j1 p1/; my @set2 = qw/a2 z2 d2 e b2 k2/; $root->load( 'lista=' . join( ',', @set1 ) . ' lista:.sort lista:.insort(' . join( ',', @set2 ) . ')' ); eq_or_diff( [ $lista->fetch_all_values ], [ sort( @set1, @set2 ) ], "check insort result" ); # test insort with a tricky value my $tricky = q!libmodule-build-perl (>= 0.421100-2)!; $root->load( qq!lista:.insort("$tricky")! ); eq_or_diff( [ $lista->fetch_all_values ], [ sort( @set1, @set2, $tricky ) ], "check insort result" ); # test sort on ordered hash my $oh = $root->fetch_element('ordered_hash'); $root->load('ordered_hash:b=bv ordered_hash:a=av'); eq_or_diff( [$oh->fetch_all_indexes()],[qw/b a/], "check unsorted keys") ; $root->load('ordered_hash:.sort') ; eq_or_diff( [$oh->fetch_all_indexes()],[qw/a b/], "check sorted keys") ; # test 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") ; # test combination of annotation plus load and some utf8 $step = 'std_id#std_id_note ! std_id:ab#std_id_ab_note X=Bv X#X_note - std_id:bc X=Av X#X2_note ' . '- a_string="toto \"titi\" tata" a_string#string_note ' . 'lista:=a,b,c,d olist:0 - olist:0#olist0_note X=Av - olist:1 X=Bv - listb:=b,"c c2",d ' . '! hash_a:X2=x#x_note hash_a:Y2=xy hash_b:X3=xy my_check_list=X2,X3 ' . 'plain_object#"plain comment" aa2="aa2_value ' . "\x{263A}\""; my $inst2 = $model->instance( root_class_name => 'Master', instance_name => 'test2' ); my $root2 = $inst2->config_root; ok( $root2->load( step => $step ), "set up data in tree with combination of load and annotations" ); my @to_check = ( [ 'std_id', 'std_id_note' ], [ 'std_id:ab', 'std_id_ab_note' ], [ 'std_id:ab X', 'X_note' ], [ 'std_id:bc X', 'X2_note' ], [ 'a_string', 'string_note' ], [ 'olist:0', 'olist0_note' ], [ 'hash_a:X2', 'x_note' ], [ 'plain_object', 'plain comment' ], ); foreach (@to_check) { is( $root2->grab( $_->[0] )->annotation, $_->[1], "Check annotation for '$_->[0]'" ); } # check utf8 value is( $root2->grab_value('plain_object aa2'), "aa2_value \x{263A}", "utf8 value" ); # test deletion of leaf items $step = 'a_string=foobar a_string~'; ok( $root2->load( step => $step ), "set up data then delete it" ); is( $root2->grab_value('a_string'), undef, "check that another_string was undef'ed" ); $root2->load("lista:0.=\x{263A}"); is( $root2->grab_value('lista:0'), "a\x{263A}", "check that list append work" ); # test element with embedded dash $root->load("std_id:ab X-Y-Z=Av"); is( $root->grab_value('std_id:ab X-Y-Z'), "Av", "check load grab of X-Y-Z" ); # test deep copy $root->load("std_id:.copy(ab,copy)"); is( $root->grab_value('std_id:copy X-Y-Z'), "Av", "check hash copy" ); is( $root->grab_value('lista:5'), 'e' , "list copy" ); $root->load("lista:.copy(1,5)"); is( $root->grab_value('lista:5'), 'b2' , "list copy" ); $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" ); # test some errors cases 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.097/t/gen-class-doc.t0000644000175000017500000000153613027007223015510 0ustar domidomiuse ExtUtils::testlib; use Test::More tests => 5; use Test::Memory::Cycle; use Config::Model; use warnings; no warnings qw(once); use strict; use vars qw/$model/; $model = Config::Model->new( legacy => 'ignore', ); my $arg = shift || ''; my $trace = $arg =~ /t/ ? 1 : 0; Config::Model::Exception::Any->Trace(1) if $arg =~ /e/; use Log::Log4perl qw(:easy); Log::Log4perl->easy_init( $arg =~ /l/ ? $TRACE : $WARN ); ok( 1, "compiled" ); $model->load( 'Master', 't/big_model.pm' ); ok( 1, "big_model loaded" ); my $res = $model->get_model_doc('Master'); is_deeply( [ sort keys %$res ], [ map { "Config::Model::models::$_" } qw/Master SlaveY SlaveZ SubSlave SubSlave2/ ], "check doc classes" ); like( $res->{'Config::Model::models::Master'}, qr/Configuration class Master/, "check that doc is generated" ); memory_cycle_ok($model); Config-Model-2.097/t/array_with_data_migration.t0000644000175000017500000000545313027007223020306 0ustar domidomi# -*- cperl -*- use warnings; use ExtUtils::testlib; use Test::More; use Test::Exception; use Test::Warn; use Test::Differences; use Test::Memory::Cycle; use Config::Model; use Log::Log4perl qw(:easy :levels); BEGIN { plan tests => 11; } use strict; my $arg = shift || ''; my $log = 0; my $trace = $arg =~ /t/ ? 1 : 0; $log = 1 if $arg =~ /l/; my $home = $ENV{HOME} || ""; my $log4perl_user_conf_file = "$home/.log4config-model"; if ( $log and -e $log4perl_user_conf_file ) { Log::Log4perl::init($log4perl_user_conf_file); } else { Log::Log4perl->easy_init( $log ? $WARN : $ERROR ); } my $model = Config::Model->new(); Config::Model::Exception::Any->Trace(1) if $arg =~ /e/; ok( 1, "compiled" ); # minimal set up to get things working $model->create_config_class( name => "Master", element => [ plain_list => { type => 'list', status => 'deprecated', cargo => { type => 'leaf', value_type => 'string' }, }, list_with_data_migration => { type => 'list', migrate_values_from => '- plain_list', cargo => { type => 'leaf', value_type => 'string', }, }, list2_with_data_migration => { type => 'list', migrate_values_from => '- list_with_data_migration', cargo => { type => 'leaf', value_type => 'string', }, }, ] ); ok( 1, "config classes created" ); my $inst = $model->instance( root_class_name => 'Master', instance_name => 'test1' ); ok( $inst, "created dummy instance" ); my $root = $inst->config_root; # emulate start of file read $inst->initial_load_start; # emulate config file load my $pl = $root->fetch_element( name => 'plain_list', check => 'no' ); $pl->push(qw/foo bar/); my @old = $pl->fetch_all_values; ok( 1, "set up plain list" ); my $lwdm = $root->fetch_element('list_with_data_migration'); ok( $lwdm, "create list_with_data_migration element" ); $lwdm->fetch_with_id(0)->store('baz0'); # check data prior to migration eq_or_diff( [ $lwdm->fetch_all_values ], ['baz0'], "list data before migration" ); # emulate end of file read $inst->initial_load_stop; # test data migration stuff eq_or_diff( [ $lwdm->fetch_all_indexes ], [ 0 .. 2 ], "list size after migration" ); eq_or_diff( [ $lwdm->fetch_all_values ], [ baz0 => @old ], "list data migration (@old)" ); my $lwdm2 = $root->fetch_element('list2_with_data_migration'); ok( $lwdm2, "create list2_with_data_migration element" ); eq_or_diff( [ $lwdm2->fetch_all_values ], [ baz0 => @old ], "list2 data migration (@old)" ); memory_cycle_ok( $model, "test memory cycles" ); Config-Model-2.097/t/node-load.t0000644000175000017500000000505313027007223014731 0ustar domidomi# -*- cperl -*- use ExtUtils::testlib; use Test::More tests => 13; use Test::Memory::Cycle; use Config::Model; use 5.010; use warnings; use strict; use lib 't/lib'; my $model = Config::Model->new(); my $arg = shift || ''; my $trace = $arg =~ /t/ ? 1 : 0; Config::Model::Exception::Any->Trace(1) if $arg =~ /e/; use Log::Log4perl qw(:easy); Log::Log4perl->easy_init( $arg =~ /l/ ? $TRACE : $WARN ); ok( 1, "compiled" ); $model->create_config_class ( name => "OverriddenNode", class => 'DummyNode', element => [ [qw/foo bar baz/ ] => { type => 'leaf', value_type => 'uniline' }, ], ) ; $model->create_config_class ( name => "PlainNode", element => [ [qw/foo/ ] => { type => 'leaf', value_type => 'uniline' }, ], ) ; my $node = { type => 'node', config_class_name => 'OverriddenNode'} ; $model->create_config_class ( name => "OverriddenRoot", class => 'DummyNode', element => [ a_node => $node, a_list => { type => 'list', cargo => $node} , a_hash => { type => 'hash', index_type => 'string', cargo => $node}, master_switch => { type => 'leaf', value_type => 'enum', choice => [qw/plain dummy/] }, 'a_warped_node' => { type => 'warped_node', 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"); Config-Model-2.097/t/backend_ini_with_section_map.t0000644000175000017500000001461413027007223020734 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/'; my $head = << 'EOH'; ## This file was written by cme command. ## You can run 'cme edit ' to modify this file. ## Run 'cme list' to get the list of applications available on your system ## You may also modify the content of this file with your favorite editor. EOH my @below_data = split /\n/, << 'EOD2' ; [Low] foo=bar [Section1] source=1 [Section2] source=2 packages=g++-4.2-arm-linux-gnu linux-libc-dev-arm-cross [Empty] EOD2 my $w_file_below = join( "\n", $head, '', map { lc } @below_data[ 3 .. 9, 0 .. 2 ] ); # set_up data my @general_data = split /\n/, << 'EOD1' ; [General] foo=bar [Section1] source=1 [Section2] source=2 packages=g++-4.2-arm-linux-gnu linux-libc-dev-arm-cross [Empty] EOD1 my $w_file_general = join( "\n", $head, map { lc } @general_data[ 0 .. 9 ] ); # change delimiter comments my %test_setup = ( SectionMapTop => [ \@general_data, 'general', $w_file_general ], SectionMap => [ \@below_data, 'below', $w_file_below ], ); my $model = Config::Model->new(); $model->create_config_class( 'name' => 'Section', 'element' => [ 'source', { 'value_type' => 'uniline', 'type' => 'leaf' }, 'packages', { 'cargo' => { 'value_type' => 'uniline', 'type' => 'leaf' }, 'type' => 'list' }, ], ); $model->create_config_class( 'name' => 'Below', 'element' => [ foo => { qw/type leaf value_type uniline/, }, ], ); $model->create_config_class( name => 'SectionMapTop', 'read_config' => [ { 'section_map' => { 'general' => '!' }, 'backend' => 'ini_file', 'split_list_value' => '\\s+', 'join_list_value' => ' ', 'store_class_in_hash' => 'sections', force_lc_section => 1, } ], element => [ 'sections', { 'cargo' => { 'type' => 'node', 'config_class_name' => 'Section' }, 'type' => 'hash', 'index_type' => 'string' }, foo => { qw/type leaf value_type uniline/, }, ] ); $model->create_config_class( name => 'SectionMap', 'read_config' => [ { 'section_map' => { 'low' => 'below' }, 'backend' => 'ini_file', 'split_list_value' => '\\s+', 'join_list_value' => ' ', 'store_class_in_hash' => 'sections', force_lc_section => 1, } ], element => [ 'sections', { 'cargo' => { 'type' => 'node', 'config_class_name' => 'Section' }, 'type' => 'hash', 'index_type' => 'string' }, below => { qw/type node config_class_name Below/, }, foo => { qw/type leaf value_type uniline/, }, ] ); # cleanup before tests rmtree($wr_root); foreach my $test_class ( sort keys %test_setup ) { my @orig = @{ $test_setup{$test_class}[0] }; my $test_path = $test_setup{$test_class}[1]; my $written_file = $test_setup{$test_class}[2]; ok( 1, "Starting $test_class tests in $test_path dir" ); my $test1 = 'ini1'; my $wr_dir = "$wr_root/$test_path/$test1"; my $conf_file = "/etc/test.ini"; my $abs_conf_file = "$wr_dir$conf_file"; mkpath( $wr_dir . '/etc', { mode => 0755 } ) || die "can't mkpath: $!"; open( CONF, "> $abs_conf_file" ) || die "can't open $abs_conf_file: $!"; print CONF map { "$_\n" } @orig; close CONF; my $i_test = $model->instance( instance_name => $test_path, root_class_name => $test_class, root_dir => $wr_dir, config_file => $conf_file, ); ok( $i_test, "Created $test_class instance" ); my $i_root = $i_test->config_root; my $orig = $i_root->dump_tree; print $orig if $trace; is( $i_root->needs_save, 0, "check data does not need to be saved" ); is( $i_root->grab_value("sections:section2 packages:0"), "g++-4.2-arm-linux-gnu", "check auto-split 1/2" ); is( $i_root->grab_value("sections:section2 packages:1"), "linux-libc-dev-arm-cross", "check auto-split 2/2" ); # force write back $i_root->needs_save(1); $i_test->write_back( config_file => $conf_file ); ok( 1, "IniFile write back done" ); my $ini_file = $wr_dir . '/etc/test.ini'; ok( -e $ini_file, "check that config file $ini_file was written" ); file_contents_eq_or_diff $ini_file, $written_file, "check file $ini_file content"; # create another instance to read the IniFile that was just written my $wr_dir2 = "$wr_root/$test_path/ini2"; mkpath( $wr_dir2 . '/etc', { mode => 0755 } ) || die "can't mkpath: $!"; copy( $wr_dir . '/etc/test.ini', $wr_dir2 . '/etc/' ) or die "can't copy from test1 to test2: $!"; my $i2_test = $model->instance( instance_name => $test_path . '2', root_class_name => $test_class, root_dir => $wr_dir2, config_file => $conf_file, ); ok( $i2_test, "Created instance" ); my $i2_root = $i2_test->config_root; my $p2_dump = $i2_root->dump_tree; $i_root->load('sections~empty'); my $orig_fixed = $i_root->dump_tree; eq_or_diff( [ split /\n/, $p2_dump ], [ split /\n/, $orig_fixed ], "compare original data with 2nd instance data" ); } memory_cycle_ok($model); done_testing; Config-Model-2.097/t/search_element.t0000644000175000017500000004223313027007223016046 0ustar domidomi# -*- cperl -*- use ExtUtils::testlib; use Test::More tests => 24; use Test::Memory::Cycle; use Config::Model; use warnings; no warnings qw(once); use strict; use Data::Dumper; # use Config::Model::ObjTreeScanner; use vars qw/$model/; $model = Config::Model->new( legacy => 'ignore', ); my $arg = shift || ''; my $trace = $arg =~ /t/ ? 1 : 0; Config::Model::Exception::Any->Trace(1) if $arg =~ /e/; $Data::Dumper::Indent = 1; use Log::Log4perl qw(:easy); Log::Log4perl->easy_init( $arg =~ /l/ ? $TRACE : $WARN ); ok( 1, "compiled" ); my $inst = $model->instance( root_class_name => 'Master', model_file => 't/big_model.pm', instance_name => 'test1' ); ok( $inst, "created dummy instance" ); my $root = $inst->config_root; ok( $root, "created root" ); Config::Model::Exception::Any->Trace(1) if $trace =~ /e/; my @data = ( [ 'Z', "std_id:foo", { 'Z' => { 'next_step' => { 'Z' => '' } }, 'X' => { 'next_step' => { 'X' => '' } }, 'DX' => { 'next_step' => { 'DX' => '' } } } ], [ 'ab2', 'warp', { 'ab2' => { 'next_step' => { 'warp2' => { 'next_class' => { 'SubSlave2' => { 'next_step' => { 'ab2' => '' } } } }, 'sub_slave' => { 'next_step' => { 'sub_slave' => { 'next_step' => { 'ab2' => '' } } } } } }, 'aa2' => { 'next_step' => { 'warp2' => { 'next_class' => { 'SubSlave2' => { 'next_step' => { 'aa2' => '' } } } }, 'sub_slave' => { 'next_step' => { 'sub_slave' => { 'next_step' => { 'aa2' => '' } } } } } }, 'X' => { 'next_step' => { 'X' => '', 'std_id' => { 'next_step' => { 'X' => '' } } } }, 'ac' => { 'next_step' => { 'sub_slave' => { 'next_step' => { 'ac' => '' } } } }, 'Y' => { 'next_step' => { 'Y' => '' } }, 'DX' => { 'next_step' => { 'std_id' => { 'next_step' => { 'DX' => '' } } } }, 'Z' => { 'next_step' => { 'warp2' => { 'next_class' => { 'SubSlave2' => { 'next_step' => { 'Z' => '' } } } }, 'std_id' => { 'next_step' => { 'Z' => '' } }, 'sub_slave' => { 'next_step' => { 'sub_slave' => { 'next_step' => { 'Z' => '' } } } } } }, 'ab' => { 'next_step' => { 'sub_slave' => { 'next_step' => { 'ab' => '' } } } }, 'ad2' => { 'next_step' => { 'warp2' => { 'next_class' => { 'SubSlave2' => { 'next_step' => { 'ad2' => '' } } } }, 'sub_slave' => { 'next_step' => { 'sub_slave' => { 'next_step' => { 'ad2' => '' } } } } } }, 'ad' => { 'next_step' => { 'sub_slave' => { 'next_step' => { 'ad' => '' } } } }, 'aa' => { 'next_step' => { 'sub_slave' => { 'next_step' => { 'aa' => '' } } } }, 'ac2' => { 'next_step' => { 'warp2' => { 'next_class' => { 'SubSlave2' => { 'next_step' => { 'ac2' => '' } } } }, 'sub_slave' => { 'next_step' => { 'sub_slave' => { 'next_step' => { 'ac2' => '' } } } } } } } ], [ 'Z', '!', { 'string_with_def' => { 'next_step' => { 'string_with_def' => '' } }, 'aa2' => { 'next_step' => { 'slave_y' => { 'next_step' => { 'warp2' => { 'next_class' => { 'SubSlave2' => { 'next_step' => { 'aa2' => '' } } } }, 'sub_slave' => { 'next_step' => { 'sub_slave' => { 'next_step' => { 'aa2' => '' } } } } } }, 'warp' => { 'next_class' => { 'SlaveY' => { 'next_step' => { 'warp2' => { 'next_class' => { 'SubSlave2' => { 'next_step' => { 'aa2' => '' } } } }, 'sub_slave' => { 'next_step' => { 'sub_slave' => { 'next_step' => { 'aa2' => '' } } } } } } } } } }, 'Y' => { 'next_step' => { 'slave_y' => { 'next_step' => { 'Y' => '' } }, 'warp' => { 'next_class' => { 'SlaveY' => { 'next_step' => { 'Y' => '' } } } } } }, 'DX' => { 'next_step' => { 'slave_y' => { 'next_step' => { 'std_id' => { 'next_step' => { 'DX' => '' } } } }, 'olist' => { 'next_step' => { 'DX' => '' } }, 'warp' => { 'next_class' => { 'SlaveZ' => { 'next_step' => { 'DX' => '' } }, 'SlaveY' => { 'next_step' => { 'std_id' => { 'next_step' => { 'DX' => '' } } } } } }, 'std_id' => { 'next_step' => { 'DX' => '' } } } }, 'Z' => { 'next_step' => { 'slave_y' => { 'next_step' => { 'warp2' => { 'next_class' => { 'SubSlave2' => { 'next_step' => { 'Z' => '' } } } }, 'std_id' => { 'next_step' => { 'Z' => '' } }, 'sub_slave' => { 'next_step' => { 'sub_slave' => { 'next_step' => { 'Z' => '' } } } } } }, 'olist' => { 'next_step' => { 'Z' => '' } }, 'warp' => { 'next_class' => { 'SlaveZ' => { 'next_step' => { 'Z' => '' } }, 'SlaveY' => { 'next_step' => { 'warp2' => { 'next_class' => { 'SubSlave2' => { 'next_step' => { 'Z' => '' } } } }, 'std_id' => { 'next_step' => { 'Z' => '' } }, 'sub_slave' => { 'next_step' => { 'sub_slave' => { 'next_step' => { 'Z' => '' } } } } } } } }, 'std_id' => { 'next_step' => { 'Z' => '' } } } }, 'ad2' => { 'next_step' => { 'slave_y' => { 'next_step' => { 'warp2' => { 'next_class' => { 'SubSlave2' => { 'next_step' => { 'ad2' => '' } } } }, 'sub_slave' => { 'next_step' => { 'sub_slave' => { 'next_step' => { 'ad2' => '' } } } } } }, 'warp' => { 'next_class' => { 'SlaveY' => { 'next_step' => { 'warp2' => { 'next_class' => { 'SubSlave2' => { 'next_step' => { 'ad2' => '' } } } }, 'sub_slave' => { 'next_step' => { 'sub_slave' => { 'next_step' => { 'ad2' => '' } } } } } } } } } }, 'tree_macro' => { 'next_step' => { 'tree_macro' => '' } }, 'a_string' => { 'next_step' => { 'a_string' => '' } }, 'ad' => { 'next_step' => { 'slave_y' => { 'next_step' => { 'sub_slave' => { 'next_step' => { 'ad' => '' } } } }, 'warp' => { 'next_class' => { 'SlaveY' => { 'next_step' => { 'sub_slave' => { 'next_step' => { 'ad' => '' } } } } } } } }, 'ordered_hash' => { 'next_step' => { 'ordered_hash' => '' } }, 'aa' => { 'next_step' => { 'slave_y' => { 'next_step' => { 'sub_slave' => { 'next_step' => { 'aa' => '' } } } }, 'warp' => { 'next_class' => { 'SlaveY' => { 'next_step' => { 'sub_slave' => { 'next_step' => { 'aa' => '' } } } } } } } }, 'ac2' => { 'next_step' => { 'slave_y' => { 'next_step' => { 'warp2' => { 'next_class' => { 'SubSlave2' => { 'next_step' => { 'ac2' => '' } } } }, 'sub_slave' => { 'next_step' => { 'sub_slave' => { 'next_step' => { 'ac2' => '' } } } } } }, 'warp' => { 'next_class' => { 'SlaveY' => { 'next_step' => { 'warp2' => { 'next_class' => { 'SubSlave2' => { 'next_step' => { 'ac2' => '' } } } }, 'sub_slave' => { 'next_step' => { 'sub_slave' => { 'next_step' => { 'ac2' => '' } } } } } } } } } }, 'lista' => { 'next_step' => { 'lista' => '' } }, 'hash_b' => { 'next_step' => { 'hash_b' => '' } }, 'ab2' => { 'next_step' => { 'slave_y' => { 'next_step' => { 'warp2' => { 'next_class' => { 'SubSlave2' => { 'next_step' => { 'ab2' => '' } } } }, 'sub_slave' => { 'next_step' => { 'sub_slave' => { 'next_step' => { 'ab2' => '' } } } } } }, 'warp' => { 'next_class' => { 'SlaveY' => { 'next_step' => { 'warp2' => { 'next_class' => { 'SubSlave2' => { 'next_step' => { 'ab2' => '' } } } }, 'sub_slave' => { 'next_step' => { 'sub_slave' => { 'next_step' => { 'ab2' => '' } } } } } } } } } }, 'int_v' => { 'next_step' => { 'int_v' => '' } }, 'listb' => { 'next_step' => { 'listb' => '' } }, 'my_reference' => { 'next_step' => { 'my_reference' => '' } }, 'X' => { 'next_step' => { 'slave_y' => { 'next_step' => { 'X' => '', 'std_id' => { 'next_step' => { 'X' => '' } } } }, 'olist' => { 'next_step' => { 'X' => '' } }, 'warp' => { 'next_class' => { 'SlaveZ' => { 'next_step' => { 'X' => '' } }, 'SlaveY' => { 'next_step' => { 'X' => '', 'std_id' => { 'next_step' => { 'X' => '' } } } } } }, 'std_id' => { 'next_step' => { 'X' => '' } } } }, 'ac' => { 'next_step' => { 'slave_y' => { 'next_step' => { 'sub_slave' => { 'next_step' => { 'ac' => '' } } } }, 'warp' => { 'next_class' => { 'SlaveY' => { 'next_step' => { 'sub_slave' => { 'next_step' => { 'ac' => '' } } } } } } } }, 'a_uniline' => { 'next_step' => { 'a_uniline' => '' } }, 'ab' => { 'next_step' => { 'slave_y' => { 'next_step' => { 'sub_slave' => { 'next_step' => { 'ab' => '' } } } }, 'warp' => { 'next_class' => { 'SlaveY' => { 'next_step' => { 'sub_slave' => { 'next_step' => { 'ab' => '' } } } } } } } }, 'my_check_list' => { 'next_step' => { 'my_check_list' => '' } }, 'hash_a' => { 'next_step' => { 'hash_a' => '' } } } ] ); my @items = $root->model_searcher->get_searchable_elements; my @expected = qw/DX X Y Z a_string a_uniline aa aa2 ab ab2 ac ac2 ad ad2 hash_a hash_b int_v lista listb my_check_list my_reference ordered_hash string_with_def tree_macro/; is_deeply( \@items, \@expected, "list of searchable items" ); foreach my $item (@data) { next unless @$item == 3; my $node = $root->grab( $item->[1] ); my $model_searcher = $node->model_searcher->prepare( element => $item->[0] ); is_deeply( $model_searcher->{data}, $item->[2], "verify search data on " . $node->config_class_name . "($item->[0],$item->[1])" ) || print Dumper $model_searcher->{data}; } my $model_searcher = $root->model_searcher->prepare( element => 'X' ); $root->load("tree_macro=XZ"); my $step = $model_searcher->next_step(); is_deeply( $step, [qw/olist slave_y std_id warp/], 'check first step' ); my $obj = $model_searcher->choose('warp'); is( $obj->name, 'warp', 'check chosen object' ); my $target = $model_searcher->auto_choose( sub { }, sub { } ); is( $target->name, 'warp X', 'check auto chosen object for X' ); $step = $model_searcher->next_step(); is_deeply( $step, [], 'check that no more steps are left' ); # no user choice to look for aa $root->load("tree_macro=XY"); $model_searcher = $root->model_searcher->prepare( element => 'aa' ); $model_searcher->choose('warp'); $target = $model_searcher->auto_choose( sub { }, sub { } ); is( $target->name, 'warp sub_slave aa', 'check auto chosen object for aa' ); # try choose_next $model_searcher = $root->model_searcher->prepare( element => 'aa' ); $model_searcher->choose('warp'); $step = $model_searcher->next_choice(); is_deeply( $step, [], 'check that no more steps are left after next_choice' ); $target = $model_searcher->current_object; is( $target->name, 'warp sub_slave aa', 'check chosen object for aa' ); $model_searcher = $root->model_searcher->prepare( element => 'DX' ); $root->load("tree_macro=XZ"); my $cb1 = sub { my $object = shift; is( $object->config_class_name, 'Master', 'check object of element call-back (DX))' ); is_deeply( [@_], [qw/olist slave_y std_id warp/], 'check param of element call-back (DX)' ); return 'warp'; }; $target = $model_searcher->auto_choose( $cb1, sub { } ); is( $target->name, 'warp DX', 'check auto chosen object for DX (warp)' ); # restart and try through olist $model_searcher->reset; $target = $model_searcher->auto_choose( sub { 'olist' }, sub { return 1; } ); is( $target->name, 'olist:1 DX', 'check auto_choose target for DX (olist)' ); # restart and try through std_d $model_searcher->reset; $target = $model_searcher->auto_choose( sub { 'std_id' }, sub { return 'foo'; } ); is( $target->name, 'std_id:foo DX', 'check auto_choose target for DX (std_id)' ); # restart and try through std_d with next_choice $model_searcher->reset; $step = $model_searcher->next_choice(); is_deeply( $step, [qw/olist slave_y std_id warp/], 'next_choice 1' ); $model_searcher->choose('std_id'); ok( 1, "std_id choice done" ); #print $root->dump_tree(full_dump =>1) ; $step = $model_searcher->next_choice(); is_deeply( $step, [], 'next_choice 2' ); is( $model_searcher->current_object->name, 'std_id:foo DX', 'next_choice target' ); memory_cycle_ok($model); Config-Model-2.097/t/include.t0000644000175000017500000000510213027007223014505 0ustar domidomi# -*- cperl -*- use warnings; use ExtUtils::testlib; use Test::More; use Test::Exception; use Test::Differences; use Test::Memory::Cycle; use Config::Model; use Data::Dumper; use strict; my $arg = shift || ''; my $trace = $arg =~ /t/ ? 1 : 0; Config::Model::Exception::Any->Trace(1) if $arg =~ /e/; use Log::Log4perl qw(:easy); Log::Log4perl->easy_init( $arg =~ /l/ ? $TRACE : $WARN ); ok( 1, "Compilation done" ); # minimal set up to get things working my $model = Config::Model->new(); $model->create_config_class( name => "Two", element => [ two => { type => 'leaf', value_type => 'string', }, ] ); $model->create_config_class( name => "Three", element => [ three => { type => 'leaf', value_type => 'string', }, ] ); $model->create_config_class( name => "Four", include => [qw/Three/], element => [ four => { type => 'leaf', value_type => 'string', }, ] ); $model->create_config_class( name => "Master", include => [qw/Two Four/], include_after => 'one', element => [ one => { type => 'leaf', value_type => 'string', }, ] ); my $inst = $model->instance( root_class_name => 'Master', instance_name => 'test1' ); ok( $inst, "created dummy instance" ); my $root = $inst->config_root; my @elt = $root->get_element_name(); is_deeply( \@elt, [qw/one two three four/], "check multiple include order" ); my @bad_class = ( name => "EvilMaster", include => [qw/Master/], element => [ one => { type => 'leaf', value_type => 'string', }, ] ); # failure occurs later $model->create_config_class(@bad_class); throws_ok { $model->get_model('EvilMaster'); } qr/cannot clobber/i, "Check that include does not clobber elements"; # test include of read/write spec $model->create_config_class( name => 'LikeXorg', 'include_backend' => [ 'Xorg::ConfigDir' ], element => [ one => { type => 'leaf', value_type => 'string', }, ], ); my $read_config = [{ 'auto_create' => 1, 'backend' => 'Xorg', 'config_dir' => '/etc/X11', 'file' => 'xorg.conf' }] ; $model->create_config_class( 'name' => 'Xorg::ConfigDir', 'read_config' => $read_config ); my $xorg_model = $model->get_model('LikeXorg'); eq_or_diff($xorg_model->{read_config}, $read_config,"check included read specification"); memory_cycle_ok($model, "memory cycles"); done_testing; Config-Model-2.097/t/node_get_set.t0000644000175000017500000000246613027007223015533 0ustar domidomi# -*- cperl -*- use ExtUtils::testlib; use Test::More tests => 9; use Test::Memory::Cycle; use Config::Model; use warnings; no warnings qw(once); use strict; my $model = Config::Model->new( legacy => 'ignore', ); my $arg = shift || ''; my $trace = $arg =~ /t/ ? 1 : 0; Config::Model::Exception::Any->Trace(1) if $arg =~ /e/; use Log::Log4perl qw(:easy); Log::Log4perl->easy_init( $arg =~ /l/ ? $TRACE : $WARN ); ok( 1, "compiled" ); my $inst = $model->instance( root_class_name => 'Master', model_file => 't/big_model.pm', instance_name => 'test1' ); ok( $inst, "created dummy instance" ); my $root = $inst->config_root; # check with embedded \n my $step = qq!std_id:ab X=Bv - std_id:bc X=Av - a_string="titi and toto" !; ok( $root->load( step => $step ), "load '$step'" ); foreach ( [ "/std_id/cc/X", "Bv" ], ) { my ( $path, $exp ) = @$_; is( $root->set( $path, $exp ), 1, "Test set $path" ); } foreach ( [ "/std_id/bc/X", "Av" ], [ "/std_id/cc/X", "Bv" ], ) { my ( $path, $exp ) = @$_; is( $root->get($path), $exp, "Test get $path" ); } is( $root->get( path => "/std_id/bc/X", get_obj => 1 ), $root->grab("std_id:bc X"), "test get with get_obj" ); is( $root->get( path => '/BDMV', check => 'skip' ), undef, "get with check skip does not die" ); memory_cycle_ok($model); Config-Model-2.097/t/term_ui.t0000644000175000017500000000605713027007223014540 0ustar domidomi# -*- cperl -*- use ExtUtils::testlib; use Test::More; use Test::Differences; # this block is necessary to avoid failure on some automatic cpan # testers setup which fail while loading Term::ReadLine BEGIN { my $ok = eval { require Term::ReadLine; my $test = new Term::ReadLine 'Test'; 1; } and ( eval { require Term::ReadLine::Gnu; 1; } or eval { require Term::ReadLine::Perl; 1; } ); if ($ok) { plan tests => 13; } else { plan skip_all => "Cannot load Term::ReadLine"; } } use Test::Memory::Cycle; use Config::Model; use Config::Model::TermUI; use warnings; no warnings qw(once); use strict; use Data::Dumper; use vars qw/$model/; $model = Config::Model->new( legacy => 'ignore', ); my $arg = shift || ''; my $trace = $arg =~ /t/ ? 1 : 0; Config::Model::Exception::Any->Trace(1) if $arg =~ /e/; use Log::Log4perl qw(:easy); Log::Log4perl->easy_init( $arg =~ /l/ ? $TRACE : $WARN ); note("you can run the test in interactive mode by passing 'i' argument, i.e. perl -Ilib t/term_ui.t i"); ok( 1, "compiled" ); my $inst = $model->instance( root_class_name => 'Master', model_file => 't/big_model.pm', instance_name => 'test1' ); ok( $inst, "created dummy instance" ); my $root = $inst->config_root; my $step = 'std_id:ab X=Bv - ' . 'std_id:bc X=Av - ' . 'std_id:"abc def" X=Av - ' . 'std_id:"abc hij" X=Av - ' . 'a_string="toto tata"'; ok( $root->load( step => $step ), "set up data in tree with '$step'" ); # this test test only execution of user command, not their actual # input my $prompt = 'Test Prompt'; my $term_ui = Config::Model::TermUI->new( root => $root, title => 'Test Title', prompt => $prompt, ); if ($arg =~ /i/) { $term_ui->run_loop; exit; } my @std_id_list = ('std_id:','std_id:ab','std_id:"abc def"' ,'std_id:"abc hij"', 'std_id:bc') ; my @test = ( # text line start ## expected completions [ [ '', '', 0 ], [qw/cd changes check clear delete desc description display dump fix help ll ls reset save set tree/] ], [ [ '', 'cd ', 3 ], [ '!', '-', @std_id_list , 'olist:', 'warp','slave_y' ] ], [ [ 's', 'cd s', 3 ], [ @std_id_list, 'slave_y' ] ], [ [ 'sl', 'cd sl', 3 ], ['slave_y'] ], [ [ 'std_id:', 'cd std_id:', 10 ], \@std_id_list ], [ [ 'std_id:"', 'cd std_id:"', 11 ], ['std_id:"abc def"' ,'std_id:"abc hij"' ] ], [ [ 'std_id:"abc', 'cd std_id:"abc',14 ], ['std_id:"abc def"' ,'std_id:"abc hij"' ] ], [ [ 'std_id:a', 'cd std_id:a', 3 ], ['std_id:ab'] ], [ [ '', 'fix ', 4 ], ['std_id', 'lista', 'listb', 'hash_a', 'hash_b', 'ordered_hash', 'olist', 'tree_macro', 'warp', 'slave_y', 'string_with_def', 'a_uniline', 'a_string', 'int_v', 'my_check_list', 'my_reference', '!'] ], ); 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.097/t/describe_node.t0000644000175000017500000001753213027007223015661 0ustar domidomi# -*- cperl -*- use ExtUtils::testlib; use Test::More; use Test::Memory::Cycle; use Test::Warn; use Config::Model; use warnings; no warnings qw(once); use strict; use utf8; use open qw(:std :utf8); # undeclared streams in UTF-8 use vars qw/$model/; $model = Config::Model->new( legacy => 'ignore', ); my $arg = shift || ''; my $trace = $arg =~ /t/ ? 1 : 0; Config::Model::Exception::Any->Trace(1) if $arg =~ /e/; use Log::Log4perl qw(:easy); Log::Log4perl->easy_init( $arg =~ /l/ ? $TRACE : $WARN ); ok( 1, "compiled" ); $model->load(Master => 't/big_model.pm'); ok( 1, "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" ); 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 - ' . 'list_with_warn_duplicates=foo,bar,foo ' . 'my_check_list=toto my_reference="titi"'; ok( $root->load( step => $step ), "set up data in tree with '$step'" ); # so that list_with_warn_duplicates comes with '/!\' warning_like {$root->deep_check;} qr/Duplicated value/,"Found duplicated value"; 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 my_reference │ reference │ titi list_with_warn_duplicates ⚠ │ list │ foo,bar,foo EOF is( $description, $expect, "check root description " ); $description = $root->describe(hide_empty => 1, verbose => 1); $description =~ s/\s*\n/\n/g; print "description string:\n$description" if $trace; $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" │ a_uniline │ uniline │ "yada yada" │ a_string │ string │ "toto tata" │ mandatory int_v │ integer │ 10 │ my_check_list │ check_list │ toto │ my_reference │ reference │ titi │ list_with_warn_duplicates ⚠ │ list │ foo,bar,foo │ EOF is( $description, $expect, "check root description without empty values" ); $description = $root->describe(hide_empty => 1); $description =~ s/\s*\n/\n/g; print "description string:\n$description" if $trace; $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 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" ); $description = $root->grab('std_id:ab')->describe(verbose => 1); $description =~ s/\s*\n/\n/g; print "description string:\n$description" if $trace; $expect = <<'EOF' ; name │ type │ value │ comment ─────┼──────┼─────────┼───────────────────── Z │ enum │ [undef] │ choice: Av Bv Cv X │ enum │ Bv │ choice: Av Bv Cv DX │ enum │ Dv │ choice: Av Bv Cv Dv EOF is( $description, $expect, "check std_id:ab description " ); $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; $expect = <<'EOF' ; name │ type │ value │ comment ─────┼──────┼───────┼───────────────────── X │ enum │ Bv │ choice: Av Bv Cv DX │ enum │ Dv │ choice: Av Bv Cv Dv EOF is( $description, $expect, "check std_id:ab description without empty values" ); $expect = <<'EOF' ; name │ type │ value │ comment ───────┼───────────┼──────────┼───────────────────── std_id │ node hash │ │ keys: "ab" "bc" EOF $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" ); $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 $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" ); memory_cycle_ok($model, "check memory cycles"); done_testing; Config-Model-2.097/t/lib/0000755000175000017500000000000013027007223013445 5ustar domidomiConfig-Model-2.097/t/lib/DummyNode.pm0000644000175000017500000000046313027007223015707 0ustar domidomi# # This file is part of Config-Model # # This software is Copyright (c) 2005-2016 by Dominique Dumont. # # This is free software, licensed under: # # The GNU Lesser General Public License, Version 2.1, February 1999 # package DummyNode; use base qw/Config::Model::Node/; sub dummy { $_[1]++; } 1; Config-Model-2.097/t/check_list_warp.t0000644000175000017500000000506113027007223016227 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 Log::Log4perl qw(:easy); my ( $log, $show ) = (0) x 3; my $arg = shift || ''; my $trace = $arg =~ /t/ ? 1 : 0; $log = 1 if $arg =~ /l/; $show = 1 if $arg =~ /s/; Config::Model::Exception::Any->Trace(1) if $arg =~ /e/; my $home = $ENV{HOME} || ""; my $log4perl_user_conf_file = "$home/.log4config-model"; if ( $log and -e $log4perl_user_conf_file ) { Log::Log4perl::init($log4perl_user_conf_file); } else { Log::Log4perl->easy_init( $arg =~ /l/ ? $DEBUG : $WARN ); } ok( 1, "Compilation done" ); my $model = Config::Model->new(); my @slave_classes = ('Slave0' .. 'Slave1'); my @master_elems ; foreach my $slave_class (@slave_classes) { $model->create_config_class( name => $slave_class, element => [ [qw/X Y/] => { type => 'leaf', value_type => 'enum', choice => [qw/Av Bv Cv/] } ] ); push @master_elems , $slave_class => { type => 'warped_node', level => 'hidden', config_class_name => $slave_class, 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); done_testing; Config-Model-2.097/t/value_simple_warp.t0000644000175000017500000001110513027007223016600 0ustar domidomi# -*- cperl -*- use warnings; use ExtUtils::testlib; use Test::More; use Test::Memory::Cycle; use Config::Model; use Data::Dumper; BEGIN { plan tests => 24; } use strict; my $arg = shift || ''; my $trace = $arg =~ /t/ ? 1 : 0; Config::Model::Exception::Any->Trace(1) if $arg =~ /e/; use Log::Log4perl qw(:easy); Log::Log4perl->easy_init( $arg =~ /l/ ? $TRACE : $WARN ); ok( 1, "Compilation done" ); my @rules = ( F => { choice => [qw/A B C F F2/], default => 'F' }, G => { choice => [qw/A B C G G2/], default => 'G' } ); my @args = ( value_type => 'enum', mandatory => 1, choice => [qw/A B C/] ); my $model = Config::Model->new( legacy => 'ignore', ); $model->create_config_class( name => "Master", element => [ enum => { type => 'leaf', class => 'Config::Model::Value', value_type => 'enum', choice => [qw/F G H/], default => undef }, wrong_syntax_rule => { type => 'leaf', class => 'Config::Model::Value', warp => { follow => '- enum', rules => [ F => [ default => 'F' ] ] }, @args }, warped_object => { type => 'leaf', class => 'Config::Model::Value', @args, warp => { follow => '- enum', rules => \@rules } }, recursive_warped_object => { type => 'leaf', class => 'Config::Model::Value', @args, warp => { follow => '- warped_object', rules => \@rules } }, [qw/w2 w3/] => { type => 'leaf', class => 'Config::Model::Value', @args, warp => { follow => '- enum', rules => \@rules }, }, ], # dummy class ); # check model content my $canonical_model = $model->get_element_model( 'Master', 'warped_object' ); is_deeply( $canonical_model->{warp}, { 'follow' => { 'f1' => '- enum' }, 'rules' => [ '$f1 eq \'F\'', { 'default' => 'F', 'choice' => [ 'A', 'B', 'C', 'F', 'F2' ] }, '$f1 eq \'G\'', { 'default' => 'G', 'choice' => [ 'A', 'B', 'C', 'G', 'G2' ] } ] }, "check munged warp arguments" ); my $inst = $model->instance( root_class_name => 'Master', instance_name => 'test1' ); ok( $inst, "created dummy instance" ); my $root = $inst->config_root; my ( $w1, $w2, $w3, $bad_w, $rec_wo, $t ); eval { $bad_w = $root->fetch_element('wrong_syntax_rule'); }; ok( $@, "set up warped object with wrong rules syntax" ); print "normal error:\n", $@, "\n" if $trace; eval { $t = $bad_w->fetch; }; ok( $@, "wrong rules semantic warped object blows up" ); print "normal error:\n", $@, "\n" if $trace; ok( $w1 = $root->fetch_element('warped_object'), "set up warped object" ); eval { my $str = $w1->fetch; }; ok( $@, "try to read warped object while warp master is undef" ); print "normal error:\n", $@, "\n" if $trace; my $warp_master = $root->fetch_element('enum'); is( $warp_master->store('F'), 1, "store F in warp master" ); is( $w1->fetch, 'F', "read warped object default value" ); is( $w1->store('F2'), 1, "store F2 in warped object" ); is( $w1->fetch, 'F2', "and read" ); ok( $rec_wo = $root->fetch_element('recursive_warped_object'), "set up recursive_warped_object" ); eval { my $str = $rec_wo->fetch; }; ok( $@, "try to read recursive warped object while its warp master is F2" ); print "normal error:\n", $@, "\n" if $trace; eval { $t = $rec_wo->fetch; }; ok( $@, "recursive_warped_object blows up" ); print "normal error:\n", $@, "\n" if $trace; is( $w1->store('F'), 1, "store F in warped object" ); is( $rec_wo->fetch, 'F', "read recursive_warped_object: default value was set by warp master" ); $warp_master->store('G'); is( $w1->fetch, 'G', "warp 'enum' so that F2 value is clobbered (outside new choice)" ); $w1->store('A'); $warp_master->store('F'); is( $w1->fetch, 'A', "set value valid for both warp, warp w1 to G and test that the value is still ok" ); $w2 = $root->fetch_element('w2'); $w3 = $root->fetch_element('w3'); is( $w2->fetch, 'F', "test unset value for w2 after setting warp master" ); is( $w3->fetch, 'F', "idem for w3" ); $warp_master->store('G'); is( $w1->fetch, 'A', "set warp master to G and test unset value for w1 ... 2 and w3" ); is( $w2->fetch, 'G', "... and w2 ..." ); is( $w3->fetch, 'G', "... and w3" ); memory_cycle_ok($model); Config-Model-2.097/t/simple_ui.t0000644000175000017500000000600713027007223015055 0ustar domidomi# -*- cperl -*- use ExtUtils::testlib; use Test::More tests => 27; use Test::Memory::Cycle; use Config::Model; use Config::Model::SimpleUI; use warnings; no warnings qw(once); use strict; use utf8; use open qw(:std :utf8); # undeclared streams in UTF-8 use Data::Dumper; use vars qw/$model/; $model = Config::Model->new( legacy => 'ignore', ); my $arg = shift || ''; my $trace = $arg =~ /t/ ? 1 : 0; Config::Model::Exception::Any->Trace(1) if $arg =~ /e/; use Log::Log4perl qw(:easy); Log::Log4perl->easy_init( $arg =~ /l/ ? $TRACE : $WARN ); note("you can run the test in interactive mode by passing 'i' argument, i.e. perl -Ilib t/simple_ui.t i"); ok( 1, "compiled" ); my $inst = $model->instance( root_class_name => 'Master', model_file => 't/big_model.pm', instance_name => 'test1' ); ok( $inst, "created dummy instance" ); my $root = $inst->config_root; my $step = 'std_id:ab X=Bv - std_id:bc X=Av - a_string="toto tata"'; ok( $root->load( step => $step ), "set up data in tree with '$step'" ); # this test test only execution of user command, not their actual # input my $prompt = 'Test Prompt'; my $ui = Config::Model::SimpleUI->new( root => $root, title => 'Test Title', prompt => $prompt, ); my $expected_prompt = $prompt . ':$ '; ok( $ui, "Created ui" ); if ($arg =~ /i/) { $ui->run_loop; exit; } my $path = $ui->list_cd_path; is_deeply( $path, [ qw/std_id:ab std_id:bc tree_macro warp slave_y string_with_def a_uniline a_string int_v my_check_list my_reference/ ], 'check list cd path at root' ); is( $ui->prompt, $expected_prompt, 'test prompt at root' ); my @test = ( [ 'vf std_id:ab', "Unexpected command 'vf'", $expected_prompt ], [ 'ls', 'std_id lista listb hash_a hash_b ordered_hash olist tree_macro warp slave_y string_with_def a_uniline a_string int_v my_check_list my_reference', $expected_prompt ], [ 'ls hash*', 'hash_a hash_b', $expected_prompt], [ 'll hash*', "name │ 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); Config-Model-2.097/t/dump_as_data.t0000644000175000017500000001265013027007223015511 0ustar domidomi# -*- cperl -*- use ExtUtils::testlib; use Test::More tests => 38; use Test::Memory::Cycle; use Config::Model; use warnings; no warnings qw(once); use strict; use vars qw/$model/; $model = Config::Model->new( legacy => 'ignore', ); my $arg = shift || ''; my $trace = $arg =~ /t/ ? 1 : 0; Config::Model::Exception::Any->Trace(1) if $arg =~ /e/; use Log::Log4perl qw(:easy); Log::Log4perl->easy_init( $arg =~ /l/ ? $TRACE : $ERROR ); ok( 1, "compiled" ); my $inst = $model->instance( root_class_name => 'Master', model_file => 't/dump_load_model.pm', instance_name => 'test1' ); ok( $inst, "created dummy instance" ); my $root = $inst->config_root; ok( $root, "Config root created" ); my $step = ' std_id:ab X=Bv - std_id:bc X=Av - tree_macro=mXY another_string="toto tata" hash_a:toto=toto_value hash_a:titi=titi_value ordered_hash:z=1 ordered_hash:y=2 ordered_hash:x=3 lista=a,b,c,d olist:0 X=Av - olist:1 X=Bv - my_check_list=toto my_reference="titi" warp warp2 aa2="foo bar" '; $step =~ s/\n/ /g; ok( $root->load( step => $step ), "set up data in tree with '$step'" ); # load some values with undef $root->fetch_element('hash_a')->fetch_with_id('undef_val'); $root->fetch_element('lista')->fetch_with_id(6)->store('g'); $root->load_data( { listb => 'bb' } ); ok( 1, "loaded single array element as listb => 'bb'" ); my $data = $root->dump_as_data( full_dump => 0 ); my $expect = { 'olist' => [ { 'X' => 'Av' }, { 'X' => 'Bv' } ], 'my_check_list' => ['toto'], 'tree_macro' => 'mXY', 'ordered_hash' => [ 'z', '1', 'y', '2', 'x', '3' ], 'another_string' => 'toto tata', 'listb' => ['bb'], 'my_reference' => 'titi', 'hash_a' => { 'toto' => 'toto_value', 'titi' => 'titi_value', }, 'std_id' => { 'ab' => { 'X' => 'Bv' }, 'bc' => { 'X' => 'Av' } }, 'lista' => [qw/a b c d g/], 'warp' => { 'warp2' => { 'aa2' => 'foo bar' } }, }; #use Data::Dumper; print Dumper $data ; is_deeply( $data, $expect, "check data dump" ); # add default information provided by model to check full dump $expect->{string_with_def} = 'yada yada'; $expect->{int_v} = 10; $expect->{olist}[0]{DX} = 'Dv'; $expect->{olist}[1]{DX} = 'Dv'; $expect->{std_id}{ab}{DX} = 'Dv'; $expect->{std_id}{bc}{DX} = 'Dv'; $expect->{a_uniline} = 'yada yada'; my $full_data = $root->dump_as_data(); is_deeply( $full_data, $expect, "check full data dump" ); my $inst2 = $model->instance( root_class_name => 'Master', instance_name => 'test2' ); ok( $inst, "created 2nd dummy instance" ); my $root2 = $inst2->config_root; ok( $root2, "Config root2 created" ); $root2->load_data($data); ok( 1, "loaded perl data structure in 2nd instance" ); my $dump1 = $root->dump_tree; my $dump2 = $root2->dump_tree; is( $dump2, $dump1, "check that dump of 2nd tree is identical to dump of the first tree" ); # try partial dumps my @tries = ( [ 'olist' => $expect->{olist} ], [ 'olist:0' => $expect->{olist}[0] ], [ 'olist:0 DX' => $expect->{olist}[0]{DX} ], [ 'string_with_def' => $expect->{string_with_def} ], [ 'ordered_hash' => $expect->{ordered_hash} ], [ 'hash_a' => $expect->{hash_a} ], [ 'std_id:ab' => $expect->{std_id}{ab} ], [ 'my_check_list' => $expect->{my_check_list} ], ); foreach my $test (@tries) { my ( $path, $expect ) = @$test; my $obj = $root->grab($path); my $dump = $obj->dump_as_data(); is_deeply( $dump, $expect, "check data dump for '$path'" ); } # try dump of ordered hash as hash my $ohah_dump = $root->grab('ordered_hash')->dump_as_data( ordered_hash_as_list => 0 ); is_deeply( $ohah_dump, { __ordered_hash_order => [qw/z y x/], 'z', '1', 'y', '2', 'x', '3' }, "check dump of ordered hash as hash" ); # test ordered hash load with hash ref instead of array ref my $inst3 = $model->instance( root_class_name => 'Master', instance_name => 'test3' ); ok( $inst, "created 3rd dummy instance" ); my $root3 = $inst3->config_root; $data->{ordered_hash} = { @{ $expect->{ordered_hash} } }; $root3->load_data($data); @tries = ( [ 'olist' => $expect->{olist} ], [ 'olist:0' => $expect->{olist}[0] ], [ 'olist:0 DX' => $expect->{olist}[0]{DX} ], [ 'string_with_def' => $expect->{string_with_def} ], [ 'ordered_hash' => [qw/x 3 y 2 z 1/] ], [ 'hash_a' => $expect->{hash_a} ], [ 'std_id:ab' => $expect->{std_id}{ab} ], [ 'my_check_list' => $expect->{my_check_list} ], ); foreach my $test (@tries) { my ( $path, $expect ) = @$test; my $obj = $root3->grab($path); my $dump = $obj->dump_as_data(); is_deeply( $dump, $expect, "check data dump for '$path'" ); } # test dump of annotations as pod my %notes = map { ( $_ => $_ ? "$_ annotation\nwith long text" : "root annotation" ); } ( '', 'olist', 'olist:0', 'olist:0 DX', 'hash_a', 'std_id:ab', 'my_check_list' ); foreach ( keys %notes ) { $root->grab($_)->annotation( $notes{$_} ); } print $root->dump_tree if $trace; my $pod_notes = $root->dump_annotations_as_pod; print $pod_notes if $trace; foreach ( keys %notes ) { my $v = $notes{$_}; like( $pod_notes, qr/$v/, "found note for $_ in pod notes" ); } $root2->load_pod_annotation($pod_notes); my $pod_notes2 = $root2->dump_annotations_as_pod; is( $pod_notes2, $pod_notes, "check 2nd pod notes" ); memory_cycle_ok($model); Config-Model-2.097/t/search_in_tree.t0000644000175000017500000000367013027007223016044 0ustar domidomi# -*- cperl -*- use ExtUtils::testlib; use Test::More; use Test::Differences; use Test::Memory::Cycle; use Config::Model; use Log::Log4perl qw(:easy); use warnings; use strict; my $arg = shift; $arg = '' unless defined $arg; my ( $log, $show ) = (0) x 2; my $trace = $arg =~ /t/ ? 1 : 0; $log = 1 if $arg =~ /l/; $show = 1 if $arg =~ /s/; my $home = $ENV{HOME} || ""; my $log4perl_user_conf_file = "$home/.log4config-model"; if ( $log and -e $log4perl_user_conf_file ) { Log::Log4perl::init($log4perl_user_conf_file); } else { Log::Log4perl->easy_init( $log ? $WARN : $ERROR ); } my $model = Config::Model->new( legacy => 'ignore', ); ok( 1, "compiled" ); my $inst = $model->instance( root_class_name => 'Master', model_file => 't/big_model.pm', instance_name => 'test1' ); ok( $inst, "created dummy instance" ); my $root = $inst->config_root; my $step = 'std_id:ab X=Bv - std_id:bc X=Av - a_string="toto tata" ' . 'hash_a:X2=x hash_a:Y2=xy hash_b:X3=xy my_check_list=X2,X3 ' . 'olist:0 DX=Dv'; ok( $root->load( step => $step ), "set up data in tree with '$step'" ); my @tests = ( [qw/value toto a_string/], [qw/value tot a_string/], [qw/key ab std_id:ab/], [qw/value xy hash_a:Y2 hash_b:X3/], [ qw/description zorro/, 'warp sub_slave sub_slave Z','warp warp2 sub_slave Z', 'slave_y sub_slave sub_slave Z', 'slave_y warp2 sub_slave Z' ], [ qw/value Bv/, 'std_id:ab X' ], [ qw/value B/, 'std_id:ab X' ], [ qw/value Dv/, 'std_id:ab DX', 'std_id:bc DX', 'olist:0 DX' ], [ qw/value X3/, 'my_check_list' ], ); foreach my $ref (@tests) { my ( $type, $string, @expected ) = @$ref; my $searcher = $root->tree_searcher( type => $type ); my @res = $searcher->search($string); eq_or_diff( \@res, \@expected, "searched for $type $string" ); print "\treturned '", join( "', '", @res ), "'\n" if $trace; } memory_cycle_ok($model); done_testing; Config-Model-2.097/t/value_refer_to.t0000644000175000017500000001525713027007223016077 0ustar domidomi# -*- cperl -*- use warnings; use ExtUtils::testlib; use Test::Warn; use Test::More ; use Test::Memory::Cycle; use Test::Exception; use Config::Model; use Log::Log4perl qw(:easy :levels); use strict; my $arg = shift || ''; my ( $log, $show ) = (0) x 2; my $trace = $arg =~ /t/ ? 1 : 0; $log = 1 if $arg =~ /l/; $show = 1 if $arg =~ /s/; my $home = $ENV{HOME} || ""; my $log4perl_user_conf_file = "$home/.log4config-model"; if ( $log and -e $log4perl_user_conf_file ) { Log::Log4perl::init($log4perl_user_conf_file); } else { Log::Log4perl->easy_init( $log ? $WARN : $ERROR ); } Config::Model::Exception::Any->Trace(1) if $arg =~ /e/; ok( 1, "Compilation done" ); # minimal set up to get things working my $model = Config::Model->new( legacy => 'ignore', ); $model->create_config_class( name => 'Host', 'element' => [ if => { type => 'hash', index_type => 'string', cargo_type => 'node', config_class_name => 'If', }, trap => { type => 'leaf', value_type => 'string' } ] ); $model->create_config_class( name => 'If', element => [ ip => { type => 'leaf', value_type => 'string' } ] ); $model->create_config_class( name => 'Lan', element => [ node => { type => 'hash', index_type => 'string', cargo_type => 'node', config_class_name => 'Node', }, ] ); $model->create_config_class( name => 'Node', element => [ host => { type => 'leaf', value_type => 'reference', refer_to => '! host' }, if => { type => 'leaf', value_type => 'reference', refer_to => [ ' ! host:$h if ', h => '- host' ] }, ip => { type => 'leaf', value_type => 'string', compute => [ '$ip', ip => '! host:$h if:$card ip', h => '- host', card => '- if' ] } ] ); $model->create_config_class( name => 'Master', element => [ host => { type => 'hash', index_type => 'string', cargo_type => 'node', config_class_name => 'Host' }, lan => { type => 'hash', index_type => 'string', cargo_type => 'node', config_class_name => 'Lan' }, host_reference => { type => 'leaf', value_type => 'reference', refer_to => ['! host '], }, host_and_choice => { type => 'leaf', value_type => 'reference', refer_to => ['! host '], choice => [qw/foo bar/] }, host_and_replace => { type => 'leaf', value_type => 'reference', refer_to => ['! host '], replace => { 'fou' => 'Foo', 'barre' => 'Bar' }, }, dumb_list => { type => 'list', cargo_type => 'leaf', cargo_args => { value_type => 'string' } }, refer_to_list_enum => { type => 'leaf', value_type => 'reference', refer_to => '- dumb_list', }, refer_to_wrong_path => { type => 'leaf', value_type => 'reference', refer_to => '! unknown_class unknown_elt', }, refer_to_unknown_elt => { type => 'leaf', value_type => 'reference', refer_to => '! unknown_elt', }, ] ); my $inst = $model->instance( root_class_name => 'Master', instance_name => 'test1' ); ok( $inst, "created dummy instance" ); my $root = $inst->config_root; ok( $root, "Created Root" ); $root->load( ' host:A if:eth0 ip=10.0.0.1 - if:eth1 ip=10.0.1.1 - - host:B if:eth0 ip=10.0.0.2 - if:eth1 ip=10.0.1.2 - - ' ); ok( 1, "host setup done" ); my $node = $root->grab('lan:A node:1'); ok( $node, "got lan:A node:1" . $node->name ); $node->load('host=A'); is( $node->grab_value('host'), 'A', "setup host=A" ); $node->load('if=eth0'); is( $node->grab_value('if'), 'eth0', "set up if=eth0 " ); # magic is( $node->grab_value('ip'), '10.0.0.1', "got ip 10.0.0.1" ); $root->load( ' lan:A node:2 host=B if=eth0 - - lan:B node:1 host=A if=eth1 - node:2 host=B if=eth1 - - ' ); ok( 1, "lan setup done" ); is( $root->grab_value('lan:A node:1 ip'), '10.0.0.1', "got ip 10.0.0.1" ); is( $root->grab_value('lan:A node:2 ip'), '10.0.0.2', "got ip 10.0.0.2" ); is( $root->grab_value('lan:B node:1 ip'), '10.0.1.1', "got ip 10.0.1.1" ); is( $root->grab_value('lan:B node:2 ip'), '10.0.1.2', "got ip 10.0.1.2" ); #print distill_root( object => $root ); #print dump_root( object => $root ); my $hac = $root->fetch_element('host_and_choice'); is_deeply( [ $hac->get_choice ], [ 'A', 'B', 'bar', 'foo' ], "check that default choice and refer_to add up" ); # choice needs to be recomputed for references $root->load("host~B"); is_deeply( [ $hac->get_choice ], [ 'A', 'bar', 'foo' ], "check that default choice and refer_to follow removed elements" ); # test reference to list values $root->load("dumb_list=a,b,c,d,e"); my $rtle = $root->fetch_element("refer_to_list_enum"); is_deeply( [ $rtle->get_choice ], [qw/a b c d e/], "check choice of refer_to_list_enum" ); throws_ok { $root->fetch_element("refer_to_wrong_path"); } 'Config::Model::Exception::Model',"fetching refer_to_wrong_path" ; throws_ok { $root->fetch_element("refer_to_unknown_elt") } 'Config::Model::Exception::Model',"fetching refer_to_unknown_elt" ; warning_like { $root->fetch_element("host_reference")->store(value => 'Foo', check => 'skip') } qr/skipping value/,"store unknown host (skip mode)"; throws_ok { $root->fetch_element("host_reference")->store('Foo') } "Config::Model::Exception::WrongValue","store unknown host (failure mode)"; $root->load("host:Foo - host:Bar"); $root->fetch_element("host_reference")->store('Foo'); ok(scalar $root->fetch_element("host_reference")->check, "check reference to Foo host"); $root->load("host_and_replace=fou"); is($root->grab_value("host_and_replace"),'Foo',"check replaced host fou->Foo"); $root->load("host~Foo"); ok( !$root->fetch_element("host_reference")->check, "check reference to removed Foo host"); # todo: need an exclude parameter (to avoid cycle in config_class_name) memory_cycle_ok($model,"test memory cycle"); done_testing; Config-Model-2.097/t/backend_ini.t0000644000175000017500000001330613027007223015315 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 warnings; no warnings qw(once); use strict; my $arg = shift || ''; my $trace = $arg =~ /t/ ? 1 : 0; my $log = $arg =~ /l/ ? 1 : 0; my $home = $ENV{HOME} || ""; my $log4perl_user_conf_file = "$home/.log4config-model"; if ( $log and -e $log4perl_user_conf_file ) { Log::Log4perl::init($log4perl_user_conf_file); } else { Log::Log4perl->easy_init( $log ? $WARN : $ERROR ); } Config::Model::Exception::Any->Trace(1) if $arg =~ /e/; ok( 1, "compiled" ); # pseudo root where config files are written by config-model my $wr_root = 'wr_root/'; # set_up data my @with_semicolon_comment = my @with_one_semicolon_comment = my @with_hash_comment = ; # change delimiter comments map { s/#/;/; } @with_semicolon_comment; map { s/# foo2/; foo2/; } @with_one_semicolon_comment; sub init_test { my ($test_class, $test_data, $config_dir) = @_; my $model = Config::Model->new(); my @orig = @$test_data ; # cleanup before tests rmtree($wr_root); ok( 1, "Starting $test_class tests" ); my $test1 = 'ini1'; my $wr_dir = $wr_root . '/' . $test1; my $conf_file = "$wr_dir/etc/test.ini"; mkpath( $wr_dir . '/etc', { mode => 0755 } ) || die "can't mkpath: $!"; open( CONF, "> $conf_file" ) || die "can't open $conf_file: $!"; print CONF @orig; close CONF; my $i_test = $model->instance( instance_name => 'test_inst', root_class_name => $test_class, root_dir => $wr_dir, model_file => 't/test_ini_backend_model.pl', config_dir => $config_dir, # optional ); ok( $i_test, "Created $test_class instance" ); my $i_root = $i_test->config_root; ok( $i_root, "created $test_class tree root" ); $i_root->init; ok( 1, "$test_class root init done" ); return ($model, $i_test, $wr_dir); } sub finish { my ($test_class, $wr_dir, $model,$i_test) = @_; my $orig = $i_test->config_root->dump_tree; print $orig if $trace; $i_test->write_back; ok( 1, "IniFile write back done" ); my $ini_file = $wr_dir . '/etc/test.ini'; ok( -e $ini_file, "check that config file $ini_file was written" ); # create another instance to read the IniFile that was just written my $wr_dir2 = $wr_root . '/ini2'; mkpath( $wr_dir2 . '/etc', { mode => 0755 } ) || die "can't mkpath: $!"; copy( $wr_dir . '/etc/test.ini', $wr_dir2 . '/etc/' ) or die "can't copy from test1 to test2: $!"; my $i2_test = $model->instance( instance_name => 'test_inst2', root_class_name => $test_class, root_dir => $wr_dir2, config_dir => $i_test->config_dir, # propagate from first test instance ); ok( $i2_test, "Created instance" ); my $i2_root = $i2_test->config_root; my $p2_dump = $i2_root->dump_tree; print "2nd dump:\n",$p2_dump if $trace; is( $p2_dump, $orig, "compare original data with 2nd instance data" ); } my %test_setup = ( IniTest => [ \@with_hash_comment, 'class1' ], IniTest2 => [ \@with_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_test($test_class, $test_setup{$test_class}[0]); my $test_path = $test_setup{$test_class}[1]; my $i_root = $i_test->config_root; $i_root->load("bar:0=\x{263A}"); # utf8 smiley is( $i_root->annotation, "some global comment with embedded '#' and stuff", "check global comment" ); is( $i_root->grab($test_path)->annotation, "class1 comment", "check $test_path comment" ); is( $i_root->grab($test_path)->backend_support_annotation, 1, "check support annotation " ); my $lista_obj = $i_root->grab($test_path)->fetch_element('lista'); is( $lista_obj->annotation, '', "check $test_path lista comment" ); foreach my $i ( 1 .. 3 ) { my $elt = $lista_obj->fetch_with_id( $i - 1 ); is( $elt->fetch, "lista$i", "check lista[$i] content" ); is( $elt->annotation, "lista$i comment", "check lista[$i] comment" ); } finish ($test_class, $wr_dir, $model,$i_test); memory_cycle_ok( $model, "memory cycle test" ); } # test ini file using a check list { # IniCheck my ($model, $i_test, $wr_dir) = init_test(IniCheck => \@with_hash_comment, '/etc/'); my $i_root = $i_test->config_root; ok($i_root->grab('foo')->is_checked('foo1'),"foo foo1 choice is set"); ok($i_root->grab('foo')->is_checked('bar1') == 0,"foo bar1 choice is not set"); ok($i_root->grab('bar')->is_checked('bar1'),"bar bar1 choice is set"); # I'm cheating. To reuse test data, list is actually a check_list in test model ok($i_root->grab('class1 lista')->is_checked('nolist') == 0,"class1 lista nolist choice is not set"); ok($i_root->grab('class1 lista')->is_checked('lista2'),"class1 lista lista1 choice is set"); $i_root->grab('class1 lista')->check('nolist'); finish ('IniCheck', $wr_dir, $model,$i_test); memory_cycle_ok( $model, "memory cycle test" ); } done_testing; __DATA__ #some global comment with embedded '#' and stuff # foo1 comment also with '#' stuff foo = foo1 foo = foo2 # foo2 comment bar = bar1 baz = bazv # class1 comment [class1] lista=lista1 #lista1 comment # lista2 comment lista = lista2 # lista3 comment lista = lista3 Config-Model-2.097/t/apply_fix.t0000644000175000017500000000470213027007223015062 0ustar domidomi# -*- cperl -*- use warnings; use ExtUtils::testlib; use Test::More; use Test::Exception; use Test::Memory::Cycle; use Config::Model; use Config::Model::Value; use Data::Dumper; use Log::Log4perl qw(:easy); BEGIN { plan tests => 9; } use strict; my $arg = shift || ''; my ( $log, $show ) = (0) x 2; my $trace = $arg =~ /t/ ? 1 : 0; $log = 1 if $arg =~ /l/; $show = 1 if $arg =~ /s/; my $home = $ENV{HOME} || ""; my $log4perl_user_conf_file = "$home/.log4config-model"; if ( $log and -e $log4perl_user_conf_file ) { Log::Log4perl::init($log4perl_user_conf_file); } else { Log::Log4perl->easy_init( $log ? $WARN : $ERROR ); } ok( 1, "Compilation done" ); $Config::Model::Value::nowarning = 1 unless $trace; # minimal set up to get things working my $model = Config::Model->new(); $model->create_config_class( name => "NodeFix", element => [ 'fix-gnu' => { type => 'leaf', value_type => 'uniline', 'warn_if_match' => { 'Debian GNU/Linux' => { 'msg' => 'deprecated in favor of Debian GNU', 'fix' => 's!Debian GNU/Linux!Debian GNU!g;' }, }, }, 'fix-long' => { type => 'leaf', value_type => 'uniline', 'warn_if_match' => { '[^\\n]{10,}' => { 'msg' => 'Line too long', 'fix' => '$_ = substr $_,0,8;' }, }, } ] ); $model->create_config_class( name => "Master", element => [ [ map { "my_broken_node_$_" } (qw/a b c/) ] => { type => 'node', config_class_name => 'NodeFix', } ] ); my $inst = $model->instance( root_class_name => 'Master', instance_name => 'test1' ); ok( $inst, "created dummy instance" ); my $root = $inst->config_root; foreach my $w (qw/a b c/) { $root->load( qq!my_broken_node_$w fix-gnu="Debian GNU/Linux for $w" fix-long="$w is way too long"!); } print $root->dump_tree if $trace; $root->apply_fixes('long'); map { is( $root->grab_value("my_broken_node_$_ fix-long"), "$_ is way", "check that $_ long stuff was fixed" ); is( $root->grab_value("my_broken_node_$_ fix-gnu"), "Debian GNU/Linux for $_", "check that $_ gnu stuff was NOT fixed" ); } qw/a b c/; print $root->dump_tree if $trace; memory_cycle_ok($model); Config-Model-2.097/t/node.t0000644000175000017500000001270113027007223014012 0ustar domidomi# -*- cperl -*- use ExtUtils::testlib; use Test::More ; use Test::Exception; use Test::Warn; use Test::Memory::Cycle; use Config::Model; use warnings; no warnings qw(once); use strict; my $arg = shift || ''; my $trace = $arg =~ /t/ ? 1 : 0; Config::Model::Exception::Any->Trace(1) if $arg =~ /e/; use Log::Log4perl qw(:easy); Log::Log4perl->easy_init( $arg =~ /l/ ? $TRACE : $WARN ); ok( 1, "compiled" ); my $model = Config::Model->new(); $model->create_config_class( name => 'Sarge', status => [ D => 'deprecated' ], #could be obsolete, standard description => [ X => 'X-ray (long description)' ], summary => [ X => 'X-ray (summary)' ], class => 'Config::Model::Node', element => [ [qw/D X Y Z/] => { type => 'leaf', class => 'Config::Model::Value', value_type => 'enum', choice => [qw/Av Bv Cv/] } ], ); $model->create_config_class( name => 'Captain', element => [ bar => { type => 'node', config_class_name => 'Sarge' } ] ); $model->create_config_class( name => "Master", level => [ qw/captain/ => 'important' ], element => [ captain => { type => 'node', config_class_name => 'Captain', }, [qw/array_args hash_args/] => { type => 'node', config_class_name => 'Captain', }, ], class_description => "Master description", description => [ captain => "officer", array_args => 'not officer' ] ); ok( 1, "Model created" ); my $instance = $model->instance( root_class_name => 'Master', instance_name => 'test1' ); ok( 1, "Instance created" ); my $root = $instance->config_root; ok( $root, "Config root created" ); is( $root->config_class_name, 'Master', "Created Master" ); is_deeply( [ sort $root->get_element_name( ) ], [qw/array_args captain hash_args/], "check Master elements" ); is_deeply( [ sort $root->get_element_name( ) ], [qw/array_args captain hash_args/], "check Master elements" ); is_deeply( [ sort $root->get_element_name( ) ], [qw/array_args captain hash_args/], "check Master elements" ); my $w = $root->fetch_element('captain'); ok( $w, "Created Captain" ); is( $w->config_class_name, 'Captain', "test class_name" ); is( $w->element_name, 'captain', "test element_name" ); is( $w->name, 'captain', "test name" ); is( $w->location, 'captain', "test captain location" ); my $b = $w->fetch_element('bar'); ok( $b, "Created Sarge" ); is( $b->fetch_element_value('Z'), undef, "test Z value" ); warning_like { $b->fetch_element('D'); } qr/Element 'D' of node 'captain bar' is deprecated/, 'Check deprecated element warning'; my $tested = $root->fetch_element('hash_args')->fetch_element('bar'); is( $tested->config_class_name, 'Sarge', "test bar config_class_name" ); is( $tested->element_name, 'bar', "test bar element_name" ); is( $tested->name, 'hash_args bar', "test bar name" ); is( $tested->location, 'hash_args bar', "test bar location" ); my $inst2 = $model->instance( root_class_name => 'Master', instance_name => 'test2' ); isa_ok( $inst2, 'Config::Model::Instance', "Created 2nd Master" ); isa_ok( $inst2->config_root, 'Config::Model::Node', "created 2nd tree" ); # test help included with the model is( $root->get_help, "Master description", "Test master global help" ); is( $root->get_help('captain'), "officer", "Test master slot help captain" ); is( $root->get_help('hash_args'), '', "Test master slot help hash_args" ); is( $tested->get_help('X'), "X-ray (long description)", "Test sarge slot help X" ); is( $tested->get_help( description => 'X' ), "X-ray (long description)", "Test sarge slot help X (description)" ); is( $tested->get_help( summary => 'X' ), "X-ray (summary)", "Test sarge slot help X (summary)" ); is( $root->has_element('daughter'), 0, "Non-existing element" ); is( $root->has_element('captain'), 1, "existing element" ); is( $root->has_element( name => 'captain', type => 'node' ), 1, "existing node element" ); is( $root->has_element( name => 'captain', type => 'leaf' ), 0, "non existing leaf element" ); ok( $root->is_element_available( name => 'captain' ), "test element" ); is( $root->get_element_property( property => 'level', element => 'hash_args' ), 'normal', "test (non) importance" ); is( $root->get_element_property( property => 'level', element => 'captain' ), 'important', "test importance" ); is( $root->set_element_property( property => 'level', element => 'captain', value => 'hidden' ), 'hidden', "test importance" ); is( $root->get_element_property( property => 'level', element => 'captain' ), 'hidden', "test hidden" ); is( $root->reset_element_property( property => 'level', element => 'captain' ), 'important', "test importance" ); map { my $key_label = defined $_->[0] ? $_->[0] : 'undef'; is( $root->next_element( name => $_->[0] ), $_->[1], "test next_element ($key_label)" ); is( $root->previous_element( name => $_->[1] ), $_->[0], "test previous_element ($key_label)" ) unless ( defined $_->[0] and $_->[0] eq '' ); } ( [ undef, 'captain' ], [ '', 'captain' ], [qw/captain array_args/], [qw/array_args hash_args/] ); memory_cycle_ok($model); done_testing ; Config-Model-2.097/t/test_ini_backend_model.pl0000644000175000017500000001256513027007223017712 0ustar domidomi# # This file is part of Config-Model # # This software is Copyright (c) 2005-2016 by Dominique Dumont. # # This is free software, licensed under: # # The GNU Lesser General Public License, Version 2.1, February 1999 # # test model used by t/*.t [ { read_config => [ { backend => 'IniFile', config_dir => '/etc/', file => 'test.ini', auto_create => 1, }, ], name => 'IniTest', element => [ [qw/foo bar/] => { type => 'list', cargo => { type => 'leaf', value_type => 'uniline', } }, [qw/baz/] => { qw/type leaf value_type uniline/, }, [qw/class1 class2/] => { type => 'node', config_class_name => 'IniTest::Class' } ] }, { read_config => [ { backend => 'IniFile', config_dir => '/etc/', file => 'test.ini', auto_create => 1, comment_delimiter => ';', }, ], name => 'IniTest2', element => [ [qw/foo bar/] => { type => 'list', cargo => { type => 'leaf', value_type => 'uniline', } }, [qw/baz/] => { qw/type leaf value_type uniline/, }, [qw/class1 class2/] => { type => 'node', config_class_name => 'IniTest::Class' } ] }, { name => 'IniTest3', read_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', read_config => [ { backend => 'IniFile', config_dir => '/etc/', file => 'test.ini', auto_create => 1, }, ], accept => [ 'class.*' => { 'type' => 'node', 'config_class_name' => 'AutoIniClass' }, '.*' => { 'type' => 'list', cargo => {qw/type leaf value_type uniline/}, } ], }, { name => 'AutoIniClass', accept => [ '.*' => { 'type' => 'list', cargo => {qw/type leaf value_type uniline/}, } ], }, { name => "MyClass", element => [ [qw/foo bar/] => { 'type' => 'list', cargo => {qw/type leaf value_type uniline/}, }, [qw/baz/] => { qw/type leaf value_type uniline/, }, 'any_ini_class' => { type => 'hash', index_type => 'string', cargo => { type => 'node', config_class_name => 'AutoIniClass' }, }, ], read_config => [ { backend => 'IniFile', config_dir => '/etc/', file => 'test.ini', store_class_in_hash => 'any_ini_class', auto_create => 1, } ], }, { name => 'IniCheck', read_config => [ { backend => 'IniFile', file => 'test.ini', auto_create => 1, }, ], element => [ [qw/foo bar/] => { type => 'check_list', choice => [qw/foo1 foo2 bar1/], }, [qw/baz/] => { qw/type leaf value_type uniline/, }, [qw/class1 class2/] => { type => 'node', config_class_name => 'IniCheckList::Class' } ] }, { name => 'IniCheckList::Class', element => [ [qw/lista/] => { type => 'check_list', choice => [qw/lista1 lista2 lista3 nolist/], }, ] }, ]; Config-Model-2.097/t/hash_with_data_migration.t0000644000175000017500000000600013027007223020100 0ustar domidomi# -*- cperl -*- use warnings; use ExtUtils::testlib; use Test::More; use Test::Exception; use Test::Warn; use Test::Differences; use Test::Memory::Cycle; use Config::Model; use Log::Log4perl qw(:easy :levels); BEGIN { plan tests => 11; } use strict; my $arg = shift || ''; my $log = 0; my $trace = $arg =~ /t/ ? 1 : 0; $log = 1 if $arg =~ /l/; my $home = $ENV{HOME} || ""; my $log4perl_user_conf_file = "$home/.log4config-model"; if ( $log and -e $log4perl_user_conf_file ) { Log::Log4perl::init($log4perl_user_conf_file); } else { Log::Log4perl->easy_init( $log ? $WARN : $ERROR ); } my $model = Config::Model->new(); Config::Model::Exception::Any->Trace(1) if $arg =~ /e/; ok( 1, "compiled" ); # minimal set up to get things working $model->create_config_class( name => "Master", element => [ plain_hash => { type => 'hash', status => 'deprecated', index_type => 'string', ordered => 1, cargo => { type => 'leaf', value_type => 'string' }, }, hash_with_data_migration => { type => 'hash', index_type => 'string', migrate_values_from => '- plain_hash', ordered => 1, cargo => { type => 'leaf', value_type => 'string', }, }, hash2_with_data_migration => { type => 'hash', index_type => 'string', migrate_values_from => '- hash_with_data_migration', ordered => 1, cargo => { type => 'leaf', value_type => 'string', }, }, ] ); ok( 1, "config classes created" ); my $inst = $model->instance( root_class_name => 'Master', instance_name => 'test1' ); ok( $inst, "created dummy instance" ); my $root = $inst->config_root; # emulate start of file read $inst->initial_load_start; # emulate config file load $root->load( step => "plain_hash:k1=foo plain_hash:k2=bar", check => 'no' ); ok( 1, "set up plain hash" ); my $hwdm = $root->fetch_element('hash_with_data_migration'); ok( $hwdm, "create hash_with_data_migration element" ); $hwdm->fetch_with_id('new')->store('baz0'); # check data prior to migration eq_or_diff( [ $hwdm->fetch_all_values ], ['baz0'], "hash data before migration" ); # emulate end of file read $inst->initial_load_stop; # test data migration stuff eq_or_diff( [ $hwdm->fetch_all_indexes ], [qw/new k1 k2/], "hash keys after migration" ); eq_or_diff( [ $hwdm->fetch_all_values ], [qw/baz0 foo bar/], "hash data after migration " ); my $hwdm2 = $root->fetch_element('hash2_with_data_migration'); ok( $hwdm2, "create hash2_with_data_migration element" ); eq_or_diff( [ $hwdm2->fetch_all_values ], [qw/baz0 foo bar/], "hash data after 2nd migration " ); memory_cycle_ok( $model, "test memory cycles" ); Config-Model-2.097/t/model_tests.t0000644000175000017500000000036313027007223015410 0ustar domidomi# -*- cperl -*- use warnings; use strict; use Config::Model::Tester 2.053; use ExtUtils::testlib; my $arg = shift || ''; my $test_only_model = shift || ''; my $do = shift; run_tests( $arg, $test_only_model, $do ); Config-Model-2.097/t/warped_node_collateral.t0000644000175000017500000001026213027007223017556 0ustar domidomi# -*- cperl -*- use warnings; use ExtUtils::testlib; use Test::More tests => 14; use Test::Exception; use Test::Memory::Cycle; use Config::Model; use Log::Log4perl qw(:easy); use strict; my ( $log, $show ) = (0) x 3; my $arg = shift || ''; my $trace = $arg =~ /t/ ? 1 : 0; $log = 1 if $arg =~ /l/; $show = 1 if $arg =~ /s/; Config::Model::Exception::Any->Trace(1) if $arg =~ /e/; my $home = $ENV{HOME} || ""; my $log4perl_user_conf_file = "$home/.log4config-model"; if ( $log and -e $log4perl_user_conf_file ) { Log::Log4perl::init($log4perl_user_conf_file); } else { Log::Log4perl->easy_init( $arg =~ /l/ ? $DEBUG : $WARN ); } ok( 1, "Compilation done" ); # minimal set up to get things working my $model = Config::Model->new( legacy => 'ignore', ); $model->create_config_class( name => 'CommonOptions', element => [ atime => { value_type => 'boolean', type => 'leaf' }, ], ); $model->create_config_class( name => 'NoneOptions', element => [ bind => { value_type => 'boolean', type => 'leaf', }, ], ); $model->create_config_class( name => 'Master', element => [ fs_vfstype => { value_type => 'enum', type => 'leaf', choice => [ 'auto', 'none', ] }, fs_mntopts => { follow => { fst => '- fs_vfstype' }, type => 'warped_node', rules => [ '$fst eq \'auto\'', { config_class_name => 'Fstab::CommonOptions' }, '$fst eq \'none\'', { config_class_name => 'Fstab::NoneOptions' }, ], }, fs_passno => { value_type => 'integer', default => 0, type => 'leaf', warp => { follow => { fstyp => '- fs_vfstype', isbound => '- fs_mntopts bind', }, rules => [ '$fstyp eq "none" and $isbound' => { max => 0, } ] } }, type => { type => 'leaf', value_type => 'enum', choice => [qw/node warped_node hash list leaf check_list/], mandatory => 1, }, cargo => { type => 'warped_node', level => 'hidden', 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); Config-Model-2.097/t/dump_load_model.pm0000644000175000017500000001640513027007223016367 0ustar domidomi# -*- cperl -*- # # This file is part of Config-Model # # This software is Copyright (c) 2005-2016 by Dominique Dumont. # # This is free software, licensed under: # # The GNU Lesser General Public License, Version 2.1, February 1999 # # this file is used by test script [ [ name => 'SubSlave2', element => [ [qw/aa2 ab2 ac2 ad2 Z/] => { type => 'leaf', value_type => 'string' } ] ], [ name => 'SubSlave', element => [ [qw/aa ab ac ad/] => { type => 'leaf', value_type => 'string' }, sub_slave => { type => 'node', config_class_name => 'SubSlave2', } ] ], [ name => 'X_base_class2', element => [ X => { type => 'leaf', value_type => 'enum', choice => [qw/Av Bv Cv/] }, ], class_description => 'rather dummy class to check include feature', ], [ name => 'X_base_class', include => 'X_base_class2', ], [ name => 'SlaveZ', element => [ [ 'Z', 'X-Y-Z' ] => { type => 'leaf', value_type => 'enum', choice => [qw/Av Bv Cv/] }, [qw/DX/] => { type => 'leaf', value_type => 'enum', default => 'Dv', choice => [qw/Av Bv Cv Dv/] }, ], include => 'X_base_class', include_after => 'Z', ], [ name => 'SlaveY', element => [ std_id => { type => 'hash', index_type => 'string', cargo_type => 'node', config_class_name => 'SlaveZ', }, sub_slave => { type => 'node', config_class_name => 'SubSlave', }, warp2 => { type => 'warped_node', 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', cargo_args => { value_type => 'string' }, }, [qw/hash_a hash_b/] => { type => 'hash', index_type => 'string', cargo_type => 'leaf', cargo_args => { value_type => 'string' }, summary => "hash_* summary", }, ordered_hash => { type => 'hash', index_type => 'string', ordered => 1, cargo_type => 'leaf', cargo_args => { value_type => 'string' }, }, 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', }, 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 }, 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.097/t/check_list.t0000644000175000017500000004303213027007223015176 0ustar domidomi# -*- cperl -*- use warnings; use ExtUtils::testlib; use Test::More; use Test::Differences; use Test::Memory::Cycle; use Config::Model; use Data::Dumper; use Log::Log4perl qw(:easy :levels); use strict; my $arg = shift || ''; my ( $log, $show ) = (0) x 2; my $trace = $arg =~ /t/ ? 1 : 0; $log = 1 if $arg =~ /l/; $show = 1 if $arg =~ /s/; my $home = $ENV{HOME} || ""; my $log4perl_user_conf_file = "$home/.log4config-model"; if ( $log and -e $log4perl_user_conf_file ) { Log::Log4perl::init($log4perl_user_conf_file); } else { Log::Log4perl->easy_init( $log ? $WARN : $ERROR ); } Config::Model::Exception::Any->Trace(1) if $arg =~ /e/; ok( 1, "Compilation done" ); # minimal set up to get things working my $model = Config::Model->new(); $model->create_config_class( name => "Master", element => [ [qw/my_hash my_hash2 my_hash3/] => { type => 'hash', index_type => 'string', cargo => { type => 'leaf', value_type => 'string' }, }, choice_list => { type => 'check_list', choice => [ 'A' .. 'Z' ], help => { A => 'A help', E => 'E help' }, }, ordered_checklist => { type => 'check_list', choice => [ 'A' .. 'Z' ], ordered => 1, help => { A => 'A help', E => 'E help' }, }, ordered_checklist_refer_to => { type => 'check_list', refer_to => '- ordered_checklist', ordered => 1, }, choice_list_with_default => { type => 'check_list', choice => [ 'A' .. 'Z' ], default_list => [ 'A', 'D' ], help => { A => 'A help', E => 'E help' }, }, choice_list_with_upstream_default => { type => 'check_list', choice => [ 'A' .. 'Z' ], upstream_default_list => [ 'A', 'D' ], help => { A => 'A help', E => 'E help' }, }, choice_list_with_default_and_upstream_default => { type => 'check_list', choice => [ 'A' .. 'Z' ], default_list => [ 'A', 'C' ], upstream_default_list => [ 'A', 'D' ], help => { A => 'A help', E => 'E help' }, }, macro => { type => 'leaf', value_type => 'enum', choice => [qw/AD AH AZ/], }, 'warped_choice_list' => { type => 'check_list', level => 'hidden', warp => { follow => '- macro', rules => { AD => { choice => [ 'A' .. 'D' ], level => 'normal', default_list => [ 'A', 'B' ] }, AH => { choice => [ 'A' .. 'H' ], level => 'normal', }, } } }, refer_to_list => { type => 'check_list', refer_to => '- my_hash' }, warped_refer_to_list => { type => 'check_list', refer_to => '- warped_choice_list', level => 'hidden', warp => { follow => '- macro', rules => { AD => { choice => [ 'A' .. 'D' ], level => 'normal', }, }, }, }, refer_to_2_list => { type => 'check_list', refer_to => '- my_hash + - my_hash2 + - my_hash3' }, refer_to_check_list_and_choice => { type => 'check_list', computed_refer_to => { formula => '- refer_to_2_list + - $var', variables => { var => '- indirection ' }, }, choice => [qw/A1 A2 A3/], }, indirection => { type => 'leaf', value_type => 'string' }, dumb_list => { type => 'list', cargo => { type => 'leaf', value_type => 'string' } }, refer_to_dumb_list => { type => 'check_list', refer_to => '- dumb_list + - my_hash', }, 'Ciphers', { 'ordered' => '1', 'upstream_default_list' => [ '3des-cbc', 'aes128-cbc', 'aes128-ctr', 'aes192-cbc', 'aes192-ctr', 'aes256-cbc', 'aes256-ctr', 'arcfour', 'arcfour128', 'arcfour256', 'blowfish-cbc', 'cast128-cbc' ], 'type' => 'check_list', 'description' => 'Specifies the ciphers allowed for protocol version 2 in order of preference. By default, all ciphers are allowed.', 'choice' => [ 'aes128-cbc', '3des-cbc', 'blowfish-cbc', 'cast128-cbc', 'arcfour128', 'arcfour256', 'arcfour', 'aes192-cbc', 'aes256-cbc', 'aes128-ctr', 'aes192-ctr', 'aes256-ctr' ] }, ] ); my $inst = $model->instance( root_class_name => 'Master', instance_name => 'test1' ); ok( $inst, "created dummy instance" ); $inst->initial_load_stop; my $root = $inst->config_root; my $cl = $root->fetch_element('choice_list'); # check get_choice is_deeply( [ $cl->get_choice ], [ 'A' .. 'Z' ], "check_get_choice" ); is( $inst->needs_save, 0, "verify instance needs_save status after creation" ); ok( 1, "test get_checked_list for empty check_list" ); my @got = $cl->get_checked_list; is( scalar @got, 0, "test nb of elt in check_list " ); is_deeply( \@got, [], "test get_checked_list after set_checked_list" ); my %expect; my $hr = $cl->get_checked_list_as_hash; is_deeply( $hr, \%expect, "test get_checked_list_as_hash for empty checklist" ); # check help is( $cl->get_help('A'), 'A help', "test help" ); is( $inst->needs_save, 0, "verify instance needs_save status after reading meta data" ); # test with the polymorphic 'set' method $cl->set( '', 'A,Z,Y,B' ); ok( 1, "test set method" ); @got = $cl->get_checked_list; is( scalar @got, 4, "test nb of elt in check_list after set" ); is_deeply( \@got, [qw/A B Y Z/], "test get_checked_list after set" ); is( $inst->needs_save, 1, "verify instance needs_save after set" ); print join( "\n", $inst->list_changes("\n") ), "\n" if $trace; $inst->clear_changes; my @set = sort qw/A C Z V Y/; $cl->set_checked_list(@set); ok( 1, "test set_checked_list" ); @got = $cl->get_checked_list; is( scalar @got, 5, "test nb of elt in check_list after set_checked_list" ); is_deeply( \@got, \@set, "test get_checked_list after set_checked_list" ); is( $inst->needs_save, 1, "verify instance needs_save after set_checked_list" ); print join( "\n", $inst->list_changes("\n") ), "\n" if $trace; $inst->clear_changes; # test global get and set as hash $hr = $cl->get_checked_list_as_hash; map { $expect{$_} = 0 } ( 'A' .. 'Z' ); map { $expect{$_} = 1 } @set; eq_or_diff( $hr, \%expect, "test get_checked_list_as_hash" ); $expect{V} = 0; $expect{W} = 1; $cl->set_checked_list_as_hash(%expect); ok( 1, "test set_checked_list_as_hash" ); @got = sort $cl->get_checked_list; is_deeply( \@got, [ sort qw/A C Z W Y/ ], "test get_checked_list after set_checked_list_as_hash" ); $cl->clear; # test global get and set @got = $cl->get_checked_list; is( scalar @got, 0, "test nb of elt in check_list after clear" ); eval { $cl->check('a'); }; ok( $@, "check 'a': which is an error" ); print "normal error:\n", $@, "\n" if $trace; # test layered choice_list $inst->layered_start; my @l_set = qw/B M W/; $cl->set_checked_list(@l_set); $inst->layered_stop; eq_or_diff( [ $cl->get_checked_list( mode => 'layered' ) ], \@l_set, "check layered content" ); eq_or_diff( [ $cl->get_checked_list( mode => 'standard' ) ], \@l_set, "check standard content" ); eq_or_diff( [ $cl->get_checked_list() ], [], "check user content" ); $cl->set_checked_list_as_hash( V => 1, W => 1 ); eq_or_diff( [ $cl->get_checked_list( mode => 'layered' ) ], \@l_set, "check layered content" ); eq_or_diff( [ $cl->get_checked_list( mode => 'standard' ) ], \@l_set, "check standard content" ); eq_or_diff( [ $cl->get_checked_list( mode => 'user' ) ], [qw/B M V W/], "check user content" ); eq_or_diff( [ $cl->get_checked_list() ], [qw/V W/], "check content" ); $cl->clear_layered; eq_or_diff( [ $cl->get_checked_list( mode => 'layered' ) ], [], "check layered content after clear" ); # now test with a refer_to parameter $root->load("my_hash:X=x my_hash:Y=y"); ok( 1, "load my_hash:X=x my_hash:Y=y worked correctly" ); my $rflist = $root->fetch_element('refer_to_list'); ok( $rflist, "created refer_to_list" ); is_deeply( [ $rflist->get_choice ], [qw/X Y/], 'check simple refer choices' ); $root->load("my_hash:Z=z"); ok( 1, "load my_hash:Z=z worked correctly" ); is_deeply( [ $rflist->get_choice ], [qw/X Y Z/], 'check simple refer choices after 2nd load' ); # load hashes that are used by reference check list $root->load("my_hash2:X2=x my_hash2:X=xy"); my $rf2list = $root->fetch_element('refer_to_2_list'); ok( $rf2list, "created refer_to_2_list" ); is_deeply( [ sort $rf2list->get_choice ], [qw/X X2 Y Z/], 'check refer_to_2_list choices' ); $root->load("my_hash3:Y2=y"); is_deeply( [ sort $rf2list->get_choice ], [qw/X X2 Y Y2 Z/], 'check refer_to_2_list choices' ); my $rtclac = $root->fetch_element('refer_to_check_list_and_choice'); ok( $rtclac, "created refer_to_check_list_and_choice" ); is_deeply( [ sort $rtclac->get_choice ], [qw/A1 A2 A3/], 'check refer_to_check_list_and_choice choices' ); eval { $rtclac->check('X'); }; ok( $@, "get_choice with undef 'indirection' parm: which is an error" ); print "normal error:\n", $@, "\n" if $trace; $root->fetch_element('indirection')->store('my_hash'); is_deeply( [ sort $rtclac->get_choice ], [qw/A1 A2 A3 X Y Z/], 'check refer_to_check_list_and_choice choices with indirection set' ); $rf2list->check('X2'); is_deeply( [ sort $rtclac->get_choice ], [ sort qw/A1 A2 A3 X X2 Y Z/ ], 'check X2 and test choices' ); # load hashes that are used by reference check list $root->load("my_hash2:X3=x"); $rf2list->check( 'X3', 'Y2' ); is_deeply( [ sort $rf2list->get_choice ], [qw/X X2 X3 Y Y2 Z/], 'check refer_to_2_list choices with X3' ); is_deeply( [ sort $rtclac->get_choice ], [qw/A1 A2 A3 X X2 X3 Y Y2 Z/], 'check refer_to_check_list_and_choice choices' ); my $dflist = $root->fetch_element('choice_list_with_default'); ok( $dflist, "created choice_list_with_default" ); @got = $dflist->get_checked_list; is_deeply( \@got, [ 'A', 'D' ], "test default of choice_list_with_default" ); @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" ); my $warp_list; eval { $warp_list = $root->fetch_element('warped_choice_list'); }; ok( $@, "fetch_element without warp set (macro=undef): which is an error" ); print "normal error:\n", $@, "\n" if $trace; # force read of hidden element $warp_list = $root->fetch_element( name => 'warped_choice_list', accept_hidden => 1 ); ok( $warp_list, "created warped_choice_list" ); eval { $warp_list->get_choice; }; ok( $@, "get_choice without warp set (macro=undef): which is an error" ); print "normal error:\n", $@, "\n" if $trace; $root->load("macro=AD"); is_deeply( [ $warp_list->get_choice ], [ 'A' .. 'D' ], 'check warp_list choice after setting macro=AD' ); @got = $warp_list->get_checked_list; is_deeply( \@got, [ 'A', 'B' ], "test default of warped_choice_list" ); $root->load("macro=AH"); is_deeply( [ $warp_list->get_choice ], [ 'A' .. 'H' ], 'check warp_list choice after setting macro=AH' ); @got = $warp_list->get_checked_list; is_deeply( \@got, [], "test default of warped_choice_list after setting macro=AH" ); # test reference to list values $root->load("dumb_list=a,b,c,d,e"); my $rtl = $root->fetch_element("refer_to_dumb_list"); is_deeply( [ $rtl->get_choice ], [qw/X Y Z a b c d e/], "check choice of refer_to_dumb_list" ); # test check list with built_in default my $wud = $root->fetch_element("choice_list_with_upstream_default"); @got = $wud->get_checked_list(); is_deeply( \@got, [], "test default of choice_list_with_upstream_default" ); @got = $wud->get_checked_list('upstream_default'); is_deeply( \@got, [qw/A D/], "test upstream_default of choice_list_with_upstream_default" ); # test check list with upstream_default *and* default (should override) $inst->clear_changes; my $wudad = $root->fetch_element("choice_list_with_default_and_upstream_default"); is( $inst->needs_save, 0, "check needs_save after reading a default value" ); @got = $wudad->get_checked_list('default'); is_deeply( \@got, [qw/A C/], "test default of choice_list_with_default_and_upstream_default" ); is( $inst->needs_save, 0, "check needs_save after reading a default value" ); @got = $wudad->get_checked_list(); is_deeply( \@got, [qw/A C/], "test choice_list_with_default_and_upstream_default" ); is( $inst->needs_save, 1, "check needs_save after reading a default value" ); is_deeply( $wudad->fetch(), 'A,C', "test fetch choice_list_with_default_and_upstream_default" ); is( $inst->needs_save, 1, "check needs_save after reading a default value" ); ### test preset feature my $pinst = $model->instance( root_class_name => 'Master', instance_name => 'preset_test' ); ok( $pinst, "created dummy preset instance" ); my $p_root = $pinst->config_root; $pinst->preset_start; ok( $pinst->preset, "instance in preset mode" ); my $p_cl = $p_root->fetch_element('choice_list'); $p_cl->set_checked_list(qw/H C L/); # acid burn test :-) $pinst->preset_stop; is( $pinst->preset, 0, "instance in normal mode" ); is( $p_cl->fetch, "C,H,L", "choice_list: read preset list" ); $p_cl->check(qw/A S H/); is( $p_cl->fetch, "A,C,H,L,S", "choice_list: read completed preset LIST" ); is( $p_cl->fetch('preset'), "C,H,L", "choice_list: read preset value as preset_value" ); is( $p_cl->fetch('standard'), "C,H,L", "choice_list: read preset value as standard_value" ); is( $p_cl->fetch('custom'), "A,C,H,L,S", "choice_list: read custom_value" ); $p_cl->set_checked_list(qw/A S H E/); is( $p_cl->fetch, "A,E,H,S", "choice_list: read overridden preset LIST" ); is( $p_cl->fetch('custom'), "A,E,H,S", "choice_list: read custom_value after override" ); my $wrtl = $p_root->fetch_element( name => 'warped_refer_to_list', accept_hidden => 1 ); ok( $wrtl, "created warped_refer_to_list (hidden)" ); my $ocl = $root->fetch_element('ordered_checklist'); @got = $ocl->get_checked_list(); is_deeply( \@got, [], "test default of ordered_checklist" ); @set = qw/A C Z V Y/; $ocl->set_checked_list(@set); @got = $ocl->get_checked_list; is_deeply( \@got, \@set, "test ordered_checklist after set_checked_list" ); $ocl->swap(qw/A Y/); @got = $ocl->get_checked_list; is_deeply( \@got, [qw/Y C Z V A/], "test ordered_checklist after swap" ); $ocl->move_up(qw/Y/); @got = $ocl->get_checked_list; is_deeply( \@got, [qw/Y C Z V A/], "test ordered_checklist after move_up Y" ); $ocl->move_up(qw/V/); @got = $ocl->get_checked_list; is_deeply( \@got, [qw/Y C V Z A/], "test ordered_checklist after move_up V" ); $ocl->move_down(qw/A/); @got = $ocl->get_checked_list; is_deeply( \@got, [qw/Y C V Z A/], "test ordered_checklist after move_down A" ); $ocl->move_down(qw/C/); @got = $ocl->get_checked_list; is_deeply( \@got, [qw/Y V C Z A/], "test ordered_checklist after move_down C" ); $ocl->check('B'); @got = $ocl->get_checked_list; is_deeply( \@got, [qw/Y V C Z A B/], "test ordered_checklist after check B" ); $ocl->move_up(qw/B/); $ocl->uncheck('B'); @got = $ocl->get_checked_list; is_deeply( \@got, [qw/Y V C Z A/], "test ordered_checklist after move_up B uncheck B" ); $ocl->check('B'); @got = $ocl->get_checked_list; is_deeply( \@got, [qw/Y V C Z B A/], "test ordered_checklist after check B" ); is( $root->grab_value( $ocl->location ), "Y,V,C,Z,B,A", "test grab_value" ); my $oclrt = $root->fetch_element('ordered_checklist_refer_to'); @got = $oclrt->get_choice(); is_deeply( \@got, [qw/Y V C Z B A/], "test default of ordered_checklist_refer_to" ); my $ciphers = $root->fetch_element('Ciphers'); my @cipher_list = qw/aes192-cbc aes128-cbc 3des-cbc blowfish-cbc aes256-cbc/; $ciphers->set_checked_list(@cipher_list); eq_or_diff( [ $ciphers->get_checked_list ], \@cipher_list, "check cipher list" ); # test warp in layered mode my $layered_i = $model->instance( root_class_name => 'Master', instance_name => 'test_layered' ); ok( $layered_i, "created layered instance" ); my $l_root = $layered_i->config_root; $layered_i->layered_start; my $locl = $l_root->fetch_element('ordered_checklist'); $locl->set_checked_list(@set); my $loclrt = $root->fetch_element('ordered_checklist_refer_to'); @got = $loclrt->get_choice(); is_deeply( \@got, [qw/Y V C Z B A/], "test default of ordered_checklist_refer_to in layered mode" ); $inst->apply_fixes; ok( 1, "apply_fixes works" ); print join( "\n", $inst->list_changes("\n") ), "\n" if $trace; memory_cycle_ok( $model, "memory cycle" ); done_testing; Config-Model-2.097/t/annotation.t0000644000175000017500000001005713027007223015241 0ustar domidomi# -*- cperl -*- use ExtUtils::testlib; use Test::More ; use Test::Memory::Cycle; use Config::Model; use Config::Model::Annotation; use File::Path; use Data::Dumper; use 5.10.0; use warnings; no warnings qw(once); use strict; use vars qw/$model/; $model = Config::Model->new( legacy => 'ignore', ); my $arg = shift || ''; my $trace = $arg =~ /t/ ? 1 : 0; Config::Model::Exception::Any->Trace(1) if $arg =~ /e/; # pseudo root where config files are written by config-model my $wr_root = 'wr_root/'; # cleanup before tests rmtree($wr_root); mkpath( $wr_root, { mode => 0755 } ); use Log::Log4perl qw(:easy); Log::Log4perl->easy_init( $arg =~ /l/ ? $TRACE : $WARN ); ok( 1, "compiled" ); my $inst = $model->instance( root_class_name => 'Master', model_file => 't/big_model.pm', root_dir => $wr_root, instance_name => 'test1' ); ok( $inst, "created dummy instance" ); my $root = $inst->config_root; ok( $root, "Config root created" ); # use Tk::ObjScanner; Tk::ObjScanner::scan_object($model) ; my $step = 'std_id:ab X=Bv - std_id:bc X=Av - a_string="toto tata" ' . 'lista=a,b,c,d olist:0 X=Av - olist:1#olist1_comment X=Bv - listb=b,c,d ' . '! hash_a:X2=x hash_a:Y2=xy hash_a:toto#"index comment" hash_b:X3=xy my_check_list=X2,X3'; ok( $root->load( step => $step ), "set up data in tree with '$step'" ); $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' ); 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 $yaml_dir = $annotate_saver->dir; is( $yaml_dir, 'wr_root/config-model/', "check saved dir" ); my $yaml_file = $annotate_saver->file; is( $yaml_file, 'wr_root/config-model/Master-note.pl', "check saved file" ); my $h_ref = $annotate_saver->get_annotation_hash(); print Dumper ($h_ref) if $trace; is_deeply( $h_ref, \%expect, "check annotation data" ); $annotate_saver->save; ok( -e $yaml_file, "check annotation file exists" ); my $inst2 = $model->instance( root_class_name => 'Master', root_dir => $wr_root, instance_name => 'test2' ); my $root2 = $inst2->config_root; my $saver2 = Config::Model::Annotation->new( config_class_name => 'Master', instance => $inst2, root_dir => $wr_root, ); $saver2->load; my $h2_ref = $saver2->get_annotation_hash(); #use Data::Dumper ; print Dumper ( $h_ref ) ; print Dumper ($h2_ref) if $trace; my %expect2 = %expect; # delete annotations loaded on missing elements delete $expect2{'std_id:bc X'}; delete $expect2{'hash_a:toto'}; delete $expect2{'olist:0'}; delete $expect2{'olist:1'}; delete $expect2{'olist:2'}; is_deeply( $h2_ref, \%expect2, "check loaded annotation data with empty tree" ); $root2->load( step => $step ); $saver2->load; my %expect3 = %expect; # delete annotations loaded on missing elements delete $expect3{'olist:2'}; my $h3_ref = $saver2->get_annotation_hash(); print Dumper ($h3_ref) if $trace; is_deeply( $h3_ref, \%expect3, "check loaded annotation data with non-empty tree" ); memory_cycle_ok($model, "memory cycles"); done_testing; Config-Model-2.097/t/smooth_upgrade.t0000644000175000017500000001333613027007223016112 0ustar domidomi# -*- cperl -*- use warnings; use ExtUtils::testlib; use Test::More tests => 22; use Test::Exception; use Test::Warn; use Test::Memory::Cycle; use Config::Model; use Config::Model::Value; use strict; my $arg = shift || ''; my $trace = $arg =~ /t/ ? 1 : 0; Config::Model::Exception::Any->Trace(1) if $arg =~ /e/; use Log::Log4perl qw(:easy); Log::Log4perl->easy_init( $arg =~ /l/ ? $TRACE : $WARN ); ok( 1, "Compilation done" ); # minimal set up to get things working my $model = Config::Model->new( legacy => 'ignore', ); $model->create_config_class( name => "Master", 'element' => [ # obsolete element cannot be used at all 'obsolete_p' => { type => 'leaf', value_type => 'enum', choice => [qw/cds perl ini custom/], status => 'obsolete', description => 'obsolete_p is replaced by non_obso', }, 'deprecated_p' => { type => 'leaf', value_type => 'enum', choice => [qw/cds perl ini custom/], status => 'deprecated', description => 'deprecated_p is replaced by new_from_deprecated', }, 'new_from_deprecated' => { type => 'leaf', value_type => 'enum', choice => [qw/cds_file perl_file ini_file augeas custom/], migrate_from => { formula => '$replace{$old}', variables => { old => '- deprecated_p' }, replace => { perl => 'perl_file', ini => 'ini_file', cds => 'cds_file', }, }, }, 'hidden_p' => { type => 'leaf', value_type => 'enum', choice => [qw/cds perl ini custom/], level => 'hidden', description => 'hidden_p is replaced by new_from_hidden', }, ] ); $model->create_config_class( name => "UrlMigration", 'element' => [ 'old_url' => { type => 'leaf', value_type => 'uniline', status => 'deprecated', }, 'host' => { type => 'leaf', value_type => 'uniline', mandatory => 1, migrate_from => { formula => '$old =~ m!http://([\w\.]+)!; $1 ;', variables => { old => '- old_url' }, use_eval => 1, }, }, 'port' => { type => 'leaf', value_type => 'uniline', migrate_from => { formula => '$old =~ m!http://[\w\.]+:(\d+)!; $1 ;', variables => { old => '- old_url' }, use_eval => 1, }, }, 'path' => { type => 'leaf', value_type => 'uniline', migrate_from => { formula => '$old =~ m!http://[\w\.]+(?::\d+)?(/.*)!; $1 ;', variables => { old => '- old_url' }, use_eval => 1, }, }, ], ); my $inst = $model->instance( root_class_name => 'Master', instance_name => 'test1' ); ok( $inst, "created dummy instance" ); my $root = $inst->config_root; # emulate start of file read $inst->initial_load_start; throws_ok { $root->fetch_element('obsolete_p'); } 'Config::Model::Exception::ObsoleteElement', 'tried to fetch obsolete element'; my $dp; warning_like { $dp = $root->fetch_element('deprecated_p'); } qr/Element 'deprecated_p' of node 'Master' is deprecated/, "check warning when fetching deprecated element"; my $nfd = $root->fetch_element('new_from_deprecated'); is( $nfd->fetch, undef, "undef old and undef new" ); # does not generate a warning $dp->store('ini'); $inst->initial_load_stop; is( $nfd->fetch, 'ini_file', "old is 'ini' and new is 'ini_file'" ); is( $nfd->fetch_custom, 'ini_file', "likewise for custom_value" ); is( $nfd->fetch('non_upstream_default'), 'ini_file', "likewise for non_builtin_default" ); is( $nfd->fetch_standard, undef, "but standard value is undef" ); # check element list is_deeply( [ $root->get_element_name ], [qw/new_from_deprecated/], "check that deprecated and obsolete parameters are hidden" ); is( $root->dump_tree, "new_from_deprecated=ini_file -\n", "check dump tree" ); # now override the migrated value $nfd->store('perl_file'); is( $nfd->fetch, 'perl_file', "overridden value is 'perl_file'" ); is( $nfd->fetch_custom, 'perl_file', "likewise for custom_value" ); is( $nfd->fetch('non_upstream_default'), 'perl_file', "likewise for non_builtin_default" ); is( $nfd->fetch_standard, undef, "but standard value is undef" ); # test migration with regexp value my $uinst = $model->instance( root_class_name => 'UrlMigration', instance_name => 'urltest' ); ok( $uinst, "created url test instance" ); my $uroot = $uinst->config_root; # emulate start of file read $uinst->initial_load_start; my $host = 'foo.gre.hp.com'; my $port = 2345; my $path = '/bar/baz.html'; my $url = "http://$host:$port$path"; # check element list is_deeply( [ $uroot->get_element_name ], [qw/host port path/], "check that url deprecated and obsolete parameters are hidden" ); warning_like { $dp = $uroot->fetch_element('old_url')->store($url); } qr/Element 'old_url' of node 'UrlMigration' is deprecated/, "check warning when fetching deprecated element"; $uinst->initial_load_stop; my $h = $uroot->fetch_element('host'); is( $h->fetch, $host, "check extracted host" ); is( $uroot->fetch_element('port')->fetch, $port, "check extracted port" ); is( $uroot->fetch_element('path')->fetch, $path, "check extracted path" ); memory_cycle_ok( $model, "test memory cycles" ); Config-Model-2.097/t/dump_tree.t0000644000175000017500000001642613027007223015061 0ustar domidomi# -*- cperl -*- use ExtUtils::testlib; use Test::More; use Test::Memory::Cycle; use Test::Differences; use Config::Model; use warnings; no warnings qw(once); use strict; use vars qw/$model/; $model = Config::Model->new( legacy => 'ignore', ); my $arg = shift || ''; my $trace = $arg =~ /t/ ? 1 : 0; Config::Model::Exception::Any->Trace(1) if $arg =~ /e/; use Log::Log4perl qw(:easy); Log::Log4perl->easy_init( $arg =~ /l/ ? $TRACE : $WARN ); ok( 1, "compiled" ); my $inst = $model->instance( root_class_name => 'Master', model_file => 't/dump_load_model.pm', instance_name => 'test1' ); ok( $inst, "created dummy instance" ); my $root = $inst->config_root; ok( $root, "Config root created" ); $inst->preset_start; $root->fetch_element( name => 'hidden_string', accept_hidden => 1 )->store('hidden value'); my $step = 'std_id:ab X=Bv ' . '! lista:=a,b listb:=b '; ok( $root->load( step => $step ), "preset data in tree with '$step'" ); $inst->preset_stop; $step = 'std_id:ab X=Bv - std_id:bc X=Av - std_id:"b d " X=Av ' . '- a_string="toto \"titi\" tata" another_string="foobar" a_string2=dod@foo.com ' . 'a_string_to_test_newline="foo\nbar\\\\nbaz" ' . 'lista:=a,b,c,d olist:0 X=Av - olist:1 X=Bv - listb:=b,"c c2",d listc:="dod@foo.com" ' . '! hash_a:X2=x hash_a:Y2=xy hash_b:X3=xy my_check_list=X2,X3 hash_b:comment_test="#"'; ok( $root->load( step => $step ), "set up data in tree" ); eq_or_diff( [ sort $root->fetch_element('std_id')->fetch_all_indexes ], [ 'ab', 'b d ', 'bc' ], "check std_id keys" ); eq_or_diff( [ sort $root->fetch_element('lista')->fetch_all_values( mode => 'custom' ) ], [qw/c d/], "check lista custom values" ); my $cds = $root->dump_tree; print "cds string:\n$cds" if $trace; my $orig_expect = <<'EOF' ; std_id:ab - std_id:"b d " X=Av - std_id:bc X=Av - lista:=c,d listb:="c c2",d listc:="dod@foo.com" hash_a:X2=x hash_a:Y2=xy hash_b:X3=xy 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( full_dump => 1 ); print "cds string:\n$cds" if $trace; my $expect = <<'EOF' ; std_id:ab X=Bv DX=Dv - std_id:"b d " X=Av DX=Dv - std_id:bc X=Av DX=Dv - lista:=a,b,c,d listb:=b,"c c2",d listc:="dod@foo.com" hash_a:X2=x hash_a:Y2=xy hash_b:X3=xy 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( full_dump => 1 ); print "cds string:\n$cds" if $trace; $expect = <<'EOF' ; std_id:ab X=Bv DX=Dv - std_id:"b d " X=Av DX=Dv - std_id:bc X=Av DX=Dv - lista:=a,b,c,d listc:="dod@foo.com" hash_a:X2=x hash_a:Y2=xy hash_b:X3=xy 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_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( full_dump => 1 ); print "cds string:\n$cds" if $trace; $cds =~ s/\s+\n/\n/g; eq_or_diff( [ split /\n/, $cds ], [ split /\n/, $expect ], "check dump of all values after a_string is set to ''" ); # check preset values $cds = $root->dump_tree( mode => 'preset' ); print "cds string:\n$cds" if $trace; $expect = <<'EOF' ; std_id:ab X=Bv - std_id:"b d " - std_id:bc - lista:=a,b olist:0 - olist:1 - - EOF $cds =~ s/\s+\n/\n/g; eq_or_diff( [ split /\n/, $cds ], [ split /\n/, $expect ], "check dump of all preset values" ); # shake warp stuff my $tm = $root->fetch_element('tree_macro'); map { $tm->store($_); } qw/XY XZ mXY XY mXY XZ/; $cds = $root->dump_tree( full_dump => 1, skip_auto_write => 'cds_file' ); print "cds string:\n$cds" if $trace; like( $cds, qr/hidden value/, "check that hidden value is shown (macro=XZ)" ); # check that list of undef is not shown map { $listb->fetch_with_id($_)->store(undef) } ( 0 .. 3 ); $cds = $root->dump_tree( full_dump => 1 ); print "Empty listb dump:\n$cds" if $trace; unlike( $cds, qr/listb/, "check that listb containing undef values is not shown" ); # reload test my $reload_root = $model->instance( root_class_name => 'Master', instance_name => 'reload_test' )->config_root; $reload_root->load($orig_expect); my $reloaded_dump = $reload_root->dump_tree; eq_or_diff( [ split /\n/, $reloaded_dump ], [ split /\n/, $orig_expect ], "check dump of tree load with dump result" ); # annotation tests my $root2 = $model->instance( root_class_name => 'Master', instance_name => 'test2' )->config_root; $step = ' std_id:ab#std_id_ab_note X=Bv X#std_id_ab_X_note - std_id#std_id_note std_id:bc X=Av X#std_id_bc_X_note ' . '- a_string="toto \"titi\" tata" a_string#a_string_note another_string="foobar"' . 'lista#lista_note lista:=a,b,c,d lista:1#lista_1_note olist#o_list_note olist:0#olist_0_note X=Av - olist:1#olist1_c X=Bv - listb:=b,"c c2",d ' . '! hash_a:X2=x#hash_a_X2 hash_a:Y2=xy#"hash_a Y2 note" hash_b:X3=xy#hash_b_X3 my_check_list=X2,X3 plain_object#"plain comment" aa2=aa2_value'; ok( $root2->load( step => $step ), "set up data in tree annotation" ); is( $root2->fetch_element('std_id')->annotation, 'std_id_note', "check annotation for std_id" ); is( $root2->grab('std_id:ab')->annotation, 'std_id_ab_note', "check annotation for std_id:ab" ); is( $root2->grab('olist:0')->annotation, 'olist_0_note', "check annotation for olist:0" ); my $expect_count = scalar grep { /#/ } split //, $step; $cds = $root2->dump_tree( full_dump => 1 ); print "Dump with annotations:\n$cds" if $trace; is( ( scalar grep { /#/ } split //, $cds ), $expect_count, "check that $expect_count annotations are found" ); my $root3 = $model->instance( root_class_name => 'Master', instance_name => 'test3' )->config_root; ok( $root3->load( step => $cds ), "set up data in tree with dumped data+annotation" ); my $cds2 = $root3->dump_tree( full_dump => 1 ); print "Dump second instance with annotations:\n$cds2" if $trace; is( $cds2, $cds, "check both dumps" ); memory_cycle_ok( $model, "memory cycles" ); done_testing; Config-Model-2.097/t/report.t0000644000175000017500000000502113027007223014375 0ustar domidomi# -*- cperl -*- # $Author$ # $Date$ # $Revision$ use ExtUtils::testlib; use Test::More tests => 9; use Test::Memory::Cycle; use Config::Model; use warnings; no warnings qw(once); use strict; use vars qw/$model/; $model = Config::Model->new( legacy => 'ignore', ); my $arg = shift || ''; my $trace = $arg =~ /t/ ? 1 : 0; Config::Model::Exception::Any->Trace(1) if $arg =~ /e/; use Log::Log4perl qw(:easy); Log::Log4perl->easy_init( $arg =~ /l/ ? $TRACE : $WARN ); ok( 1, "compiled" ); my $inst = $model->instance( root_class_name => 'Master', model_file => 't/big_model.pm', instance_name => 'test1' ); ok( $inst, "created dummy instance" ); my $root = $inst->config_root; ok( $root, "Config root created" ); my $step = 'std_id:ab X=Bv - std_id:bc X=Av - a_string="toto tata" ' . 'lista=a,b,c,d olist:0 X=Av - olist:1 X=Bv - listb=b,c,d ' . '! hash_a:X2=x hash_a:Y2=xy hash_b:X3=xy my_check_list=X2,X3'; ok( $root->load( step => $step ), "set up data in tree with '$step'" ); $step = 'tree_macro=XY'; ok( $root->load( step => $step ), "set up data in tree with '$step'" ); my $report = $root->report; print "report string:\n$report" if $trace; my $expect = <<'EOF' ; std_id:ab X = Bv std_id:ab DX = Dv std_id:bc X = Av std_id:bc DX = Dv lista:0 = a lista:1 = b lista:2 = c lista:3 = d listb:0 = b listb:1 = c listb:2 = d hash_a:X2 = x hash_a:Y2 = xy hash_b:X3 = xy olist:0 X = Av olist:0 DX = Dv olist:1 X = Bv olist:1 DX = Dv tree_macro = XY DESCRIPTION: controls behavior of other elements SELECTED: XY help string_with_def = "yada yada" a_uniline = "yada yada" a_string = "toto tata" int_v = 10 my_check_list = X2,X3 EOF is_deeply( [ split /\n/, $report ], [ split /\n/, $expect ], "check dump of only customized values " ); $report = $root->audit(); print "audit string:\n$report" if $trace; $expect = <<'EOF' ; std_id:ab X = Bv std_id:bc X = Av lista:0 = a lista:1 = b lista:2 = c lista:3 = d listb:0 = b listb:1 = c listb:2 = d hash_a:X2 = x hash_a:Y2 = xy hash_b:X3 = xy olist:0 X = Av olist:1 X = Bv tree_macro = XY DESCRIPTION: controls behavior of other elements SELECTED: XY help a_string = "toto tata" my_check_list = X2,X3 EOF is_deeply( [ split /\n/, $report ], [ split /\n/, $expect ], "check dump of all values " ); my $list = $model->list_class_element; ok( $list, "check list_class_element" ); print $list if $trace; #use Tk::ObjScanner; Tk::ObjScanner::scan_object($model) ; memory_cycle_ok($model); Config-Model-2.097/t/yaml_backend.t0000644000175000017500000000740513027007223015503 0ustar domidomi# -*- cperl -*- use ExtUtils::testlib; use Test::More; use Test::Memory::Cycle; use Config::Model; use Path::Tiny; use YAML::Any; use warnings; no warnings qw(once); use strict; use vars qw/$model/; $model = Config::Model->new(); my $arg = shift || ''; my $trace = $arg =~ /t/ ? 1 : 0; Config::Model::Exception::Any->Trace(1) if $arg =~ /e/; use Log::Log4perl qw(:easy); Log::Log4perl->easy_init( $arg =~ /l/ ? $TRACE : $ERROR ); ok( 1, "compiled" ); # pseudo root where config files are written by config-model my $wr_root = path('wr_root'); # cleanup before tests $wr_root->remove_tree; my $yaml_dir = $wr_root->child('yaml'); $yaml_dir->mkpath(); my $i_hosts = $model->instance( instance_name => 'hosts_inst', root_class_name => 'Hosts', root_dir => $wr_root->stringify, model_file => 't/test_yaml_model.pl', ); ok( $i_hosts, "Created instance" ); my $i_root = $i_hosts->config_root; my $load = "record:0 ipaddr=127.0.0.1 canonical=localhost alias=localhost - record:1 ipaddr=192.168.0.1 canonical=bilbo - - "; $i_root->load($load); $i_hosts->write_back; ok( 1, "yaml write back done" ); # TODO: test yaml content for skipped element my $yaml_file = $yaml_dir ->child('hosts.yml'); ok( $yaml_file->exists, "check that config file $yaml_file was written" ); my $written = $yaml_file->slurp; unlike($written, qr/record/, "check that list element name is not written"); # create another instance to read the yaml that was just written my $i2_hosts = $model->instance( instance_name => 'hosts_inst2', root_class_name => 'Hosts', root_dir => $wr_root->stringify, ); ok( $i2_hosts, "Created instance" ); my $i2_root = $i2_hosts->config_root; my $p2_dump = $i2_root->dump_tree; is( $p2_dump, $load, "compare original data with 2nd instance data" ); # since full_dump is null, check that dummy param is not written in yaml files my $yaml = $yaml_file->slurp || die "can't open $yaml_file:$!"; unlike( $yaml, qr/dummy/, "check yaml dump content" ); $yaml_file->remove; # test yaml content for single hash class my $i_single_hash = $model->instance( instance_name => 'single_hash', root_class_name => 'SingleHashElement', root_dir => $wr_root->stringify, ); ok( $i_single_hash, "Created single hash instance" ); $load = "record:foo ipaddr=127.0.0.1 canonical=localhost alias=localhost - record:bar ipaddr=192.168.0.1 canonical=bilbo - - "; $i_single_hash->config_root->load($load); $i_single_hash->write_back; ok( 1, "yaml single_hash write back done" ); ok( $yaml_file->exists, "check that config file $yaml_file was written" ); $yaml = $yaml_file->slurp || die "can't open $yaml_file:$!"; unlike( $yaml, qr/record/, "check single_hash yaml content" ); # test that yaml file is removed when no data is left $i_single_hash->config_root->fetch_element("record")->clear; $i_single_hash->write_back; ok( ! $yaml_file->exists, "check that config file $yaml_file was removed by clearing content" ); # idem for more complex class defined in model my $i_2_elements = $model->instance( instance_name => '2 elements', root_class_name => 'TwoElements', root_dir => $wr_root->stringify, ); ok( $i_single_hash, "Created '2 elements' instance" ); $i_2_elements->config_root->load($load); $i_2_elements->write_back; ok( 1, "yaml 2 elements write back done" ); ok( $yaml_file->exists, "check that config file $yaml_file was written" ); $yaml = $yaml_file->slurp || die "can't open $yaml_file:$!"; like( $yaml, qr/record/, "check 2 elements yaml content" ); $i_2_elements->config_root->fetch_element("record")->clear; $i_2_elements->write_back; ok( ! $yaml_file->exists, "check that config file $yaml_file was removed by clearing content" ); memory_cycle_ok( $model, "check model mem cycles" ); done_testing; Config-Model-2.097/t/instance.t0000644000175000017500000000575713027007223014706 0ustar domidomi# -*- cperl -*- use warnings; use ExtUtils::testlib; use Test::More; use Test::Warn; use Test::Memory::Cycle; use Config::Model; use strict; my $arg = shift || ''; my $trace = $arg =~ /t/ ? 1 : 0; Config::Model::Exception::Any->Trace(1) if $arg =~ /e/; use Log::Log4perl qw(:easy); Log::Log4perl->easy_init( $arg =~ /l/ ? $TRACE : $WARN ); ok( 1, "Compilation done" ); my $model = Config::Model->new( legacy => 'ignore', ); $model->create_config_class( name => "WarnMaster", element => [ warn_if => { type => 'leaf', value_type => 'string', warn_if_match => { 'foo' => { fix => '$_ = uc;' } }, }, warn_unless => { type => 'leaf', value_type => 'string', warn_unless_match => { foo => { msg => '', fix => '$_ = "foo".$_;' } }, }, ] ); my $messager ; my $inst = $model->instance( root_class_name => 'WarnMaster', instance_name => 'test1', root_dir => 'foobar', on_message_cb => sub { $messager = shift;}, ); ok( $inst, "created dummy instance" ); 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->read_root_dir, 'foobar/', "test read directory" ); is( $inst->write_root_dir, 'foobar/', "test write directory" ); # test if fixes can be applied through the instance my $root = $inst->config_root; my $wip = $root->fetch_element('warn_if'); my $wup = $root->fetch_element('warn_unless'); warning_like { $wip->store('foobar'); } qr/should not match/, "test warn_if condition (instance test)"; warning_like { $wup->store('bar'); } qr/should match/, "test warn_unless condition (instance test)"; is( $inst->has_warning, 2, "check warning count at instance level" ); $inst->apply_fixes; is( $wup->fetch, 'foobar', "test if fixes were applied (instance test)" ); is( $wup->fetch, 'foobar', "test if fixes were applied (instance test)" ); is( $inst->has_warning, 0, "check cleared warning count at instance level" ); my $binst = $model->instance( root_class_name => 'Master', model_file => 't/big_model.pm', instance_name => 'test2' ); ok( $binst, "created dummy instance" ); my $root2 = $binst->config_root; my $step = 'std_id:ab X=Bv - std_id:bc X=Av - a_string="toto tata" ' . 'lista=a,b,c,d olist:0 X=Av - olist:1 X=Bv - listb=b,c,d ' . '! hash_a:X2=x hash_a:Y2=xy hash_b:X3=xy my_check_list=X2,X3'; ok( $root2->load( step => $step ), "set up data in tree with '$step'" ); is( $binst->has_warning, 0, "test has_warning with big model" ); Config::Model::Exception::Any->Trace(1) if $trace =~ /e/; memory_cycle_ok($model); done_testing; Config-Model-2.097/t/obj_tree_scanner.t0000644000175000017500000003207413027007223016374 0ustar domidomi# -*- cperl -*- use ExtUtils::testlib; use Test::More tests => 11; use Test::Memory::Cycle; use Config::Model; use Config::Model::ObjTreeScanner; use Test::Differences; use warnings; no warnings qw(once); use strict; use Data::Dumper; # use Config::Model::ObjTreeScanner; sub disp_node_content_hook { my ( $scanner, $data_r, $node, @element ) = @_; $$data_r .= "disp_node_content_hook " . $node->name . " element: @element\n"; } sub disp_node_content { my ( $scanner, $data_r, $node, @element ) = @_; $$data_r .= "disp_node_content " . $node->name . " element: @element\n"; map { $scanner->scan_element( $data_r, $node, $_ ) } @element; } sub disp_dispatch_node_sub_slave2 { my ( $scanner, $data_r, $node, @element ) = @_; $$data_r .= "disp_dispatch_node_sub_slave2 " . $node->name . " element: @element\n"; map { $scanner->scan_element( $data_r, $node, $_ ) } @element; } sub disp_node_elt { my ( $scanner, $data_r, $node, $element, $key, $next ) = @_; $$data_r .= "disp_node_elt " . $node->name . " element: $element"; $$data_r .= " key $key" if defined $key; $$data_r .= "\n"; $scanner->scan_node( $data_r, $next ); } sub disp_hash_hook { my ( $scanner, $data_r, $node, $element, @keys ) = @_; return unless @keys; $$data_r .= "disp_hash_hook " . $node->name . " element($element): @keys\n"; } sub disp_hash { my ( $scanner, $data_r, $node, $element, @keys ) = @_; return unless @keys; $$data_r .= "disp_hash " . $node->name . " element($element): @keys\n"; map { $scanner->scan_hash( $data_r, $node, $element, $_ ) } @keys; } sub disp_list_hook { my ( $scanner, $data_r, $node, $element, @keys ) = @_; return unless @keys; $$data_r .= "disp_list_hook " . $node->name . " element($element): @keys\n"; } sub disp_check_list { my ( $scanner, $data_r, $node, $element, @choices ) = @_; return unless @choices; $$data_r .= "disp_check_list " . $node->name . " element($element): " . join( ',', $node->fetch_element($element)->get_checked_list ) . " are set\n"; } sub disp_leaf { my ( $scanner, $data_r, $node, $element, $index ) = @_; my $value = $node->fetch_element($element); $value = $value->fetch_with_id($index) if defined $index; $$data_r .= "disp_leaf " . $node->name . " element $element "; $$data_r .= "value " . $value->fetch if defined $value->fetch; $$data_r .= "\n"; } sub disp_up { my ( $scanner, $data_r, $node ) = @_; $$data_r .= "disp_up " . $node->name . "\n"; } use Log::Log4perl qw(:easy); my $arg = shift || ''; my $test_only_model = shift || ''; my $do = shift; my ( $log, $show ) = (0) x 2; my $trace = $arg =~ /t/ ? 1 : 0; $log = 1 if $arg =~ /l/; $show = 1 if $arg =~ /s/; my $home = $ENV{HOME} || ""; my $log4perl_user_conf_file = "$home/.log4config-model"; if ( $log and -e $log4perl_user_conf_file ) { Log::Log4perl::init($log4perl_user_conf_file); } else { Log::Log4perl->easy_init( $log ? $WARN : $ERROR ); } my $model = Config::Model->new( legacy => 'ignore' ); Config::Model::Exception::Any->Trace(1) if $arg =~ /e/; ok( 1, "compiled" ); my $inst = $model->instance( root_class_name => 'Master', model_file => 't/big_model.pm', instance_name => 'test1' ); ok( $inst, "created dummy instance" ); my $root = $inst->config_root; my $step = 'std_id:ab X=Bv - std_id:bc X=Av - a_string="toto tata" ' . 'hash_a:X2=x hash_a:Y2=xy hash_b:X3=xy my_check_list=X2,X3'; ok( $root->load( step => $step ), "set up data in tree with '$step'" ); my $scan = Config::Model::ObjTreeScanner->new( #min_level => 'EXPERT', list_element_cb => \&disp_hash, check_list_element_cb => \&disp_check_list, hash_element_cb => \&disp_hash, node_element_cb => \&disp_node_elt, node_content_cb => \&disp_node_content, node_dispatch_cb => { SubSlave2 => \&disp_dispatch_node_sub_slave2, }, leaf_cb => \&disp_leaf, enum_value_cb => \&disp_leaf, integer_value_cb => \&disp_leaf, number_value_cb => \&disp_leaf, boolean_value_cb => \&disp_leaf, string_value_cb => \&disp_leaf, reference_value_cb => \&disp_leaf, node_content_hook => \&disp_node_content_hook, hash_element_hook => \&disp_hash_hook, list_element_hook => \&disp_list_hook, up_cb => \&disp_up ); ok( $scan, 'set up ObjTreeScanner' ); my $result = ''; $scan->scan_node( \$result, $root ); ok( 1, "performed scan" ); print $result if $trace; my $expect = << 'EOF' ; disp_node_content_hook Master element: std_id lista listb hash_a hash_b ordered_hash olist tree_macro warp slave_y string_with_def a_uniline a_string int_v my_check_list my_reference disp_node_content Master element: std_id lista listb hash_a hash_b ordered_hash olist tree_macro warp slave_y string_with_def a_uniline a_string int_v my_check_list my_reference disp_hash_hook Master element(std_id): ab bc disp_hash Master element(std_id): ab bc disp_node_elt Master element: std_id key ab disp_node_content_hook std_id:ab element: Z X DX disp_node_content std_id:ab element: Z X DX disp_leaf std_id:ab element Z disp_leaf std_id:ab element X value Bv disp_leaf std_id:ab element DX value Dv disp_up std_id:ab disp_node_elt Master element: std_id key bc disp_node_content_hook std_id:bc element: Z X DX disp_node_content std_id:bc element: Z X DX disp_leaf std_id:bc element Z disp_leaf std_id:bc element X value Av disp_leaf std_id:bc element DX value Dv disp_up std_id:bc disp_hash_hook Master element(hash_a): X2 Y2 disp_hash Master element(hash_a): X2 Y2 disp_leaf Master element hash_a value x disp_leaf Master element hash_a value xy disp_hash_hook Master element(hash_b): X3 disp_hash Master element(hash_b): X3 disp_leaf Master element hash_b value xy disp_leaf Master element tree_macro disp_node_elt Master element: warp disp_node_content_hook warp element: X std_id sub_slave warp2 Y disp_node_content warp element: X std_id sub_slave warp2 Y disp_leaf warp element X disp_node_elt warp element: sub_slave disp_node_content_hook warp sub_slave element: aa ab ac ad sub_slave disp_node_content warp sub_slave element: aa ab ac ad sub_slave disp_leaf warp sub_slave element aa disp_leaf warp sub_slave element ab disp_leaf warp sub_slave element ac disp_leaf warp sub_slave element ad disp_node_elt warp sub_slave element: sub_slave disp_node_content_hook warp sub_slave sub_slave element: aa2 ab2 ac2 ad2 Z disp_dispatch_node_sub_slave2 warp sub_slave sub_slave element: aa2 ab2 ac2 ad2 Z disp_leaf warp sub_slave sub_slave element aa2 disp_leaf warp sub_slave sub_slave element ab2 disp_leaf warp sub_slave sub_slave element ac2 disp_leaf warp sub_slave sub_slave element ad2 disp_leaf warp sub_slave sub_slave element Z disp_up warp sub_slave sub_slave disp_up warp sub_slave disp_node_elt warp element: warp2 disp_node_content_hook warp warp2 element: aa ab ac ad sub_slave disp_node_content warp warp2 element: aa ab ac ad sub_slave disp_leaf warp warp2 element aa disp_leaf warp warp2 element ab disp_leaf warp warp2 element ac disp_leaf warp warp2 element ad disp_node_elt warp warp2 element: sub_slave disp_node_content_hook warp warp2 sub_slave element: aa2 ab2 ac2 ad2 Z disp_dispatch_node_sub_slave2 warp warp2 sub_slave element: aa2 ab2 ac2 ad2 Z disp_leaf warp warp2 sub_slave element aa2 disp_leaf warp warp2 sub_slave element ab2 disp_leaf warp warp2 sub_slave element ac2 disp_leaf warp warp2 sub_slave element ad2 disp_leaf warp warp2 sub_slave element Z disp_up warp warp2 sub_slave disp_up warp warp2 disp_leaf warp element Y disp_up warp disp_node_elt Master element: slave_y disp_node_content_hook slave_y element: X std_id sub_slave warp2 Y disp_node_content slave_y element: X std_id sub_slave warp2 Y disp_leaf slave_y element X disp_node_elt slave_y element: sub_slave disp_node_content_hook slave_y sub_slave element: aa ab ac ad sub_slave disp_node_content slave_y sub_slave element: aa ab ac ad sub_slave disp_leaf slave_y sub_slave element aa disp_leaf slave_y sub_slave element ab disp_leaf slave_y sub_slave element ac disp_leaf slave_y sub_slave element ad disp_node_elt slave_y sub_slave element: sub_slave disp_node_content_hook slave_y sub_slave sub_slave element: aa2 ab2 ac2 ad2 Z disp_dispatch_node_sub_slave2 slave_y sub_slave sub_slave element: aa2 ab2 ac2 ad2 Z disp_leaf slave_y sub_slave sub_slave element aa2 disp_leaf slave_y sub_slave sub_slave element ab2 disp_leaf slave_y sub_slave sub_slave element ac2 disp_leaf slave_y sub_slave sub_slave element ad2 disp_leaf slave_y sub_slave sub_slave element Z disp_up slave_y sub_slave sub_slave disp_up slave_y sub_slave disp_node_elt slave_y element: warp2 disp_node_content_hook slave_y warp2 element: aa ab ac ad sub_slave disp_node_content slave_y warp2 element: aa ab ac ad sub_slave disp_leaf slave_y warp2 element aa disp_leaf slave_y warp2 element ab disp_leaf slave_y warp2 element ac disp_leaf slave_y warp2 element ad disp_node_elt slave_y warp2 element: sub_slave disp_node_content_hook slave_y warp2 sub_slave element: aa2 ab2 ac2 ad2 Z disp_dispatch_node_sub_slave2 slave_y warp2 sub_slave element: aa2 ab2 ac2 ad2 Z disp_leaf slave_y warp2 sub_slave element aa2 disp_leaf slave_y warp2 sub_slave element ab2 disp_leaf slave_y warp2 sub_slave element ac2 disp_leaf slave_y warp2 sub_slave element ad2 disp_leaf slave_y warp2 sub_slave element Z disp_up slave_y warp2 sub_slave disp_up slave_y warp2 disp_leaf slave_y element Y disp_up slave_y disp_leaf Master element string_with_def value yada yada disp_leaf Master element a_uniline value yada yada disp_leaf Master element a_string value toto tata disp_leaf Master element int_v value 10 disp_check_list Master element(my_check_list): X2,X3 are set disp_leaf Master element my_reference disp_up Master EOF $result =~ s/\s+\n/\n/g; eq_or_diff( [ split /\n/, $result ], [ split /\n/, $expect ], "check result" ); my $scan2 = Config::Model::ObjTreeScanner->new( fallback => 'all', leaf_cb => \&disp_leaf ); ok( $scan2, 'set up ObjTreeScanner with fallback' ); $result = ''; $scan2->scan_node( \$result, $root ); ok( 1, 'performed scan with fallback' ); print $result if $trace; $expect = << 'EOF' ; disp_leaf std_id:ab element Z disp_leaf std_id:ab element X value Bv disp_leaf std_id:ab element DX value Dv disp_leaf std_id:bc element Z disp_leaf std_id:bc element X value Av disp_leaf std_id:bc element DX value Dv disp_leaf Master element hash_a value x disp_leaf Master element hash_a value xy disp_leaf Master element hash_b value xy disp_leaf Master element tree_macro disp_leaf warp element X disp_leaf warp sub_slave element aa disp_leaf warp sub_slave element ab disp_leaf warp sub_slave element ac disp_leaf warp sub_slave element ad disp_leaf warp sub_slave sub_slave element aa2 disp_leaf warp sub_slave sub_slave element ab2 disp_leaf warp sub_slave sub_slave element ac2 disp_leaf warp sub_slave sub_slave element ad2 disp_leaf warp sub_slave sub_slave element Z disp_leaf warp warp2 element aa disp_leaf warp warp2 element ab disp_leaf warp warp2 element ac disp_leaf warp warp2 element ad disp_leaf warp warp2 sub_slave element aa2 disp_leaf warp warp2 sub_slave element ab2 disp_leaf warp warp2 sub_slave element ac2 disp_leaf warp warp2 sub_slave element ad2 disp_leaf warp warp2 sub_slave element Z disp_leaf warp element Y disp_leaf slave_y element X disp_leaf slave_y sub_slave element aa disp_leaf slave_y sub_slave element ab disp_leaf slave_y sub_slave element ac disp_leaf slave_y sub_slave element ad disp_leaf slave_y sub_slave sub_slave element aa2 disp_leaf slave_y sub_slave sub_slave element ab2 disp_leaf slave_y sub_slave sub_slave element ac2 disp_leaf slave_y sub_slave sub_slave element ad2 disp_leaf slave_y sub_slave sub_slave element Z disp_leaf slave_y warp2 element aa disp_leaf slave_y warp2 element ab disp_leaf slave_y warp2 element ac disp_leaf slave_y warp2 element ad disp_leaf slave_y warp2 sub_slave element aa2 disp_leaf slave_y warp2 sub_slave element ab2 disp_leaf slave_y warp2 sub_slave element ac2 disp_leaf slave_y warp2 sub_slave element ad2 disp_leaf slave_y warp2 sub_slave element Z disp_leaf slave_y element Y disp_leaf Master element string_with_def value yada yada disp_leaf Master element a_uniline value yada yada disp_leaf Master element a_string value toto tata disp_leaf Master element int_v value 10 disp_leaf Master element my_check_list value X2,X3 disp_leaf Master element my_reference EOF $result =~ s/\s+\n/\n/g; eq_or_diff( [ split /\n/, $result ], [ split /\n/, $expect ], "check result" ); # test dump of mandatory values my $model2 = Config::Model->new( legacy => 'ignore', ); $model2->create_config_class( name => "SomeRootClass", element => [ a_string => { type => 'leaf', mandatory => 1, value_type => 'string' }, ], ); my $inst2 = $model2->instance( root_class_name => 'SomeRootClass', instance_name => 'test', ); my $root2 = $inst2->config_root; eval { $root2->dump_tree( auto_vivify => 1, mode => 'full' ); }; ok( $@, "expected failure of dump with empty mandatory value" ); print "normal error:", $@, "\n" if $trace; memory_cycle_ok($model); Config-Model-2.097/t/load_model_snippets.t0000644000175000017500000001121213027007223017105 0ustar domidomi# -*- cperl -*- use warnings; use ExtUtils::testlib; use Test::More; use Test::Exception; use Test::Memory::Cycle; use Test::Differences; use Config::Model; use Data::Dumper; use IO::File; use File::Path; use Log::Log4perl qw(:easy :levels); BEGIN { plan tests => 8; } use strict; use strict; my $arg = shift || ''; my ( $log, $show ) = (0) x 2; my $trace = $arg =~ /t/ ? 1 : 0; $log = 1 if $arg =~ /l/; $show = 1 if $arg =~ /s/; my $home = $ENV{HOME} || ""; my $log4perl_user_conf_file = "$home/.log4config-model"; if ( $log and -e $log4perl_user_conf_file ) { Log::Log4perl::init($log4perl_user_conf_file); } else { Log::Log4perl->easy_init( $log ? $WARN : $ERROR ); } Config::Model::Exception::Any->Trace(1) if $arg =~ /e/; ok( 1, "Compilation done" ); # pseudo root where config files are written by config-model my $wr_root = 'wr_root'; # cleanup before tests rmtree($wr_root); mkpath( $wr_root, { mode => 0755 } ); my $file = "$wr_root/Master.pl"; my $fh = IO::File->new( $file, '>' ) or die "can't open write $file:$!"; my $str = << 'EOF' ; [ { name => "Master", accept => [ '.*' => { type => 'leaf', value_type => 'uniline', } ], element => [ one => { type => 'leaf', value_type => 'string', }, fs_vfstype => { type => 'leaf', value_type => 'enum', choice => [qw/auto ext2 ext3/], }, fs_mntopts => { type => 'warped_node', 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 $fh->print($str); $fh->close; $file = "$wr_root/Two.pl"; $fh = IO::File->new( $file, '>' ) or die "can't open write $file:$!"; $str = << 'EOF' ; [{ name => "Two", element => [ two => { type => 'leaf', value_type => 'string', }, ] }] ; EOF $fh->print($str); $fh->close; my $snippet_dir = "$wr_root/Master.d"; mkpath( $snippet_dir, { mode => 0755 } ); $file = "$snippet_dir/Three.pl"; $fh = IO::File->new( $file, '>' ) or die "can't open write $file:$!"; $str = << 'EOF' ; { name => "Master", include => 'Two', include_after => 'fs_mntopts', accept => [ '.*' => { description => "catchall" }, 'ip.*' => { type => 'leaf', value_type => 'uniline', } ], element => [ three => { type => 'leaf', value_type => 'string', }, fs_vfstype => { choice => [qw/ext4/], }, fs_mntopts => { warp => { rules => [ q!$f1 eq 'ext4'!, { 'config_class_name' => 'Fstab::Ext4FsOpt' }, ] }, }, ] }; EOF $fh->print($str); $fh->close; # minimal set up to get things working my $model = Config::Model->new( model_dir => $wr_root, ); # use Tk::ObjScanner; Tk::ObjScanner::scan_object($model) ; my $inst = $model->instance( root_class_name => 'Master', instance_name => 'test1' ); ok( $inst, "created dummy instance" ); my $root = $inst->config_root; my $augmented_model = $model->get_model('Master'); print Dumper ($augmented_model) if $trace; my @elt = $root->get_element_name(); print "element list: @elt\n" if $trace; eq_or_diff( \@elt, [qw/one fs_vfstype two three/], "check augmented class" ); my $fstype = $root->fetch_element('fs_vfstype'); my @fs_choices = $fstype->get_choice; eq_or_diff( \@fs_choices, [qw/auto ext2 ext3 ext4/], "check augmented choices" ); eq_or_diff( $augmented_model->{element}{fs_mntopts}{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); Config-Model-2.097/t/value_compute.t0000644000175000017500000005100213027007223015732 0ustar domidomi# -*- cperl -*- use warnings; use ExtUtils::testlib; use Test::More; use Test::Warn; use Test::Differences; use Test::Memory::Cycle; use Config::Model; use Log::Log4perl qw(:easy); use strict; my $arg = shift || ''; my $log = 0; my $trace = $arg =~ /t/ ? 1 : 0; $log = 1 if $arg =~ /l/; Config::Model::Exception::Any->Trace(1) if $arg =~ /e/; my $home = $ENV{HOME} || ""; my $log4perl_user_conf_file = "$home/.log4config-model"; if ( $log and -e $log4perl_user_conf_file ) { Log::Log4perl::init($log4perl_user_conf_file); } else { Log::Log4perl->easy_init( $arg =~ /l/ ? $DEBUG : $WARN ); } ok( 1, "Compilation done" ); my $model = Config::Model->new(); $model->create_config_class( name => "Slave", element => [ find_node_element_name => { type => 'leaf', value_type => 'string', compute => { formula => '&element(-)', }, }, location_function_in_formula => { type => 'leaf', value_type => 'string', compute => { formula => '&location', }, }, check_node_element_name => { type => 'leaf', value_type => 'boolean', compute => { formula => '"&element(-)" eq "foo2"', }, }, [qw/av bv/] => { type => 'leaf', value_type => 'integer', compute => { variables => { p => '! &element' }, formula => '$p', }, }, ] ); # Tx to Ilya Arosov $model->create_config_class( 'name' => 'TestIndex', 'element' => [ name => { 'type' => 'leaf', 'value_type' => 'uniline', 'compute' => { 'formula' => '$my_name is my name', 'variables' => { 'my_name' => '! index_function_target:&index(-) name' } }, } ] ); $model->create_config_class( 'name' => 'TargetIndex', 'element' => [ name => { 'type' => 'leaf', 'value_type' => 'uniline', } ] ); $model->create_config_class( 'name' => 'LicenseSpec', 'element' => [ 'text', { 'value_type' => 'string', 'type' => 'leaf', 'compute' => { 'replace' => { 'GPL-1+' => "yada yada GPL-1+\nyada yada", 'Artistic' => "yada yada Artistic\nyada yada", }, 'formula' => '$replace{&index(-)}', 'allow_override' => '1', undef_is => '', }, }, short_name_from_index => { 'type' => 'leaf', 'value_type' => 'string', compute => { 'formula' => '&index( - );', 'use_eval' => 1, }, } ] ); $model->create_config_class( name => "Master", element => [ [qw/av bv/] => { type => 'leaf', class => 'Config::Model::Value', value_type => 'integer', }, compute_int => { type => 'leaf', class => 'Config::Model::Value', value_type => 'integer', compute => { formula => '$a + $b', variables => { a => '- av', b => '- bv' } }, min => -4, max => 4, }, [qw/sav sbv/] => { type => 'leaf', class => 'Config::Model::Value', value_type => 'string', }, one_var => { type => 'leaf', class => 'Config::Model::Value', value_type => 'string', compute => { formula => '&element().$bar', variables => { bar => '- sbv' } }, }, one_wrong_var => { type => 'leaf', class => 'Config::Model::Value', value_type => 'string', compute => { formula => '$bar', variables => { bar => '- wrong_v' } }, }, meet_test => { type => 'leaf', class => 'Config::Model::Value', value_type => 'string', compute => { formula => 'meet $a and $b', variables => { a => '- sav', b => '- sbv' } }, }, compute_with_override => { type => 'leaf', class => 'Config::Model::Value', value_type => 'integer', compute => { formula => '$a + $b', variables => { a => '- av', b => '- bv' }, allow_override => 1, }, min => -4, max => 4, }, compute_with_override_and_fix => { type => 'leaf', class => 'Config::Model::Value', value_type => 'uniline', compute => { formula => 'def value', allow_override => 1, }, warn_unless => { device_file => { code => 'm/def/;', msg => "not default value", fix => '$_ = undef;' } } }, # emulate imon problem where /dev/lcd0 is the default value and may not be found compute_with_override_and_powerless_fix => { type => 'leaf', class => 'Config::Model::Value', value_type => 'uniline', compute => { formula => q"my $l = '/dev/lcd-imon'; -e $l ? $l : '/dev/lcd0';", use_eval => 1, allow_override => 1, }, warn_if => { not_lcd_imon => { code => q!my $l = '/dev/lcd-imon';defined $_ and -e $l and $_ ne $l ;!, msg => "not lcd-foo.txt", fix => '$_ = undef;' }, }, warn_unless => { good_value => { code => 'defined $_ ? -e : 1;', msg => "not good value", fix => '$_ = undef;' } } }, compute_with_upstream => { type => 'leaf', class => 'Config::Model::Value', value_type => 'integer', compute => { formula => '$a + $b', variables => { a => '- av', b => '- bv' }, use_as_upstream_default => 1, }, }, compute_no_var => { type => 'leaf', value_type => 'string', compute => { formula => '&element()', }, }, [qw/bar foo2/] => { type => 'node', config_class_name => 'Slave' }, 'url' => { type => 'leaf', value_type => 'uniline', }, 'host' => { type => 'leaf', value_type => 'uniline', compute => { formula => '$url =~ m!http://([\w\.]+)!; $1 ;', variables => { url => '- url' }, use_eval => 1, }, }, 'with_tmp_var' => { type => 'leaf', value_type => 'uniline', compute => { formula => 'my $tmp = $url; $tmp =~ m!http://([\w\.]+)!; $1 ;', variables => { url => '- url' }, use_eval => 1, }, }, 'Upstream-Contact' => { 'cargo' => { 'value_type' => 'uniline', 'migrate_from' => { 'formula' => '$maintainer', 'variables' => { 'maintainer' => '- Upstream-Maintainer:&index' } }, 'type' => 'leaf' }, 'type' => 'list', }, 'Upstream-Maintainer' => { 'cargo' => { 'value_type' => 'uniline', 'migrate_from' => { 'formula' => '$maintainer', 'variables' => { 'maintainer' => '- Maintainer:&index' } }, 'type' => 'leaf' }, 'status' => 'deprecated', 'type' => 'list' }, 'Maintainer' => { 'cargo' => { 'value_type' => 'uniline', 'type' => 'leaf' }, 'type' => 'list', }, 'Source' => { 'value_type' => 'string', 'mandatory' => '1', 'migrate_from' => { 'use_eval' => '1', 'formula' => '$old || $older ;', undef_is => "''", 'variables' => { 'older' => '- Original-Source-Location', 'old' => '- Upstream-Source' } }, 'type' => 'leaf', }, 'Source2' => { 'value_type' => 'string', 'mandatory' => '1', 'compute' => { 'use_eval' => '1', 'formula' => '$old || $older ;', undef_is => "''", 'variables' => { 'older' => '- Original-Source-Location', 'old' => '- Upstream-Source' } }, 'type' => 'leaf', }, [qw/Upstream-Source Original-Source-Location/] => { 'value_type' => 'string', 'status' => 'deprecated', 'type' => 'leaf' }, Licenses => { type => 'hash', index_type => 'string', cargo => { type => 'node', config_class_name => 'LicenseSpec' } }, index_function_target => { 'type' => 'hash', 'index_type' => 'string', 'cargo' => { 'config_class_name' => 'TargetIndex', 'type' => 'node' }, }, test_index_function => { 'type' => 'hash', 'index_type' => 'string', 'cargo' => { 'config_class_name' => 'TestIndex', 'type' => 'node' }, }, 'OtherMaintainer' => { type => 'leaf', value_type => 'uniline' }, 'Vcs-Browser' => { 'type' => 'leaf', 'value_type' => 'uniline', 'compute' => { 'allow_override' => '1', 'formula' => '$maintainer =~ /pkg-(perl|ruby-extras)/p ? "http://anonscm.debian.org/gitweb/?p=${^MATCH}/packages/$pkgname.git" : undef ;', 'use_eval' => '1', 'variables' => { 'maintainer' => '- OtherMaintainer', 'pkgname' => '- Source' } } }, ] ); my $inst = $model->instance( root_class_name => 'Master', instance_name => 'test1' ); ok( $inst, "created dummy instance" ); $inst->initial_load_stop; my $root = $inst->config_root; # order is important. Do no use sort. eq_or_diff( [ $root->get_element_name() ], [ qw/av bv compute_int sav sbv one_var one_wrong_var meet_test compute_with_override compute_with_override_and_fix compute_with_override_and_powerless_fix compute_with_upstream compute_no_var bar foo2 url host with_tmp_var Upstream-Contact Maintainer Source Source2 Licenses index_function_target test_index_function OtherMaintainer Vcs-Browser/ ], "check available elements" ); my ( $av, $bv, $compute_int ); $av = $root->fetch_element('av'); $bv = $root->fetch_element('bv'); ok( $bv, "created av and bv values" ); ok( $compute_int = $root->fetch_element('compute_int'), "create computed integer value (av + bv)" ); no warnings 'once'; my $parser = new Parse::RecDescent($Config::Model::ValueComputer::compute_grammar); use warnings 'once'; { no warnings qw/once/; $::RD_HINT = 1 if $arg =~ /rdt?h/; $::RD_TRACE = 1 if $arg =~ /rdh?t/; } my $object = $root->fetch_element('one_var'); my $rules = { bar => '- sbv', }; my $srules = { bv => 'rbv' }; my $ref = $parser->pre_value( '$bar', 1, $object, $rules, $srules ); is( $$ref, '$bar', "test pre_compute parser on a very small formula: '\$bar'" ); $ref = $parser->value( '$bar', 1, $object, $rules, $srules ); is( $$ref, undef, "test compute parser on a very small formula with undef variable" ); $root->fetch_element('sbv')->store('bv'); $ref = $parser->value( '$bar', 1, $object, $rules, $srules ); is( $$ref, 'bv', "test compute parser on a very small formula: '\$bar'" ); $ref = $parser->pre_value( '$replace{$bar}', 1, $object, $rules, $srules ); is( $$ref, '$replace{$bar}', "test pre-compute parser with substitution" ); $ref = $parser->value( '$replace{$bar}', 1, $object, $rules, $srules ); is( $$ref, 'rbv', "test compute parser with substitution" ); my $txt = 'my stuff is $bar, indeed'; $ref = $parser->pre_compute( $txt, 1, $object, $rules, $srules ); is( $$ref, $txt, "test pre_compute parser with a string" ); $ref = $parser->compute( $txt, 1, $object, $rules, $srules ); is( $$ref, 'my stuff is bv, indeed', "test compute parser with a string" ); $txt = 'local stuff is element:&element!'; $ref = $parser->pre_compute( $txt, 1, $object, $rules, $srules ); is( $$ref, 'local stuff is element:one_var!', "test pre_compute parser with function (&element)" ); # In fact, function is formula is handled only by pre_compute. $ref = $parser->compute( $txt, 1, $object, $rules, $srules ); is( $$ref, $txt, "test compute parser with function (&element)" ); ## test integer formula my $result = $compute_int->fetch; is( $result, undef, "test that compute returns undef with undefined variables" ); $av->store(1); $bv->store(2); $result = $compute_int->fetch; is( $result, 3, "test result : computed integer is $result (a: 1, b: 2)" ); eval { $compute_int->store(4); }; ok( $@, "test assignment to a computed value (normal error)" ); print "normal error:\n", $@, "\n" if $trace; $result = $compute_int->fetch; is( $result, 3, "result has not changed" ); $bv->store(-2); $result = $compute_int->fetch; is( $result, -1, "test result : computed integer is $result (a: 1, b: -2)" ); ok( $bv->store(4), "change bv value" ); eval { $result = $compute_int->fetch; }; ok( $@, "computed integer: computed value error" ); print "normal error:\n", $@, "\n" if $trace; is( $compute_int->fetch( check => 0 ), undef, "test result : computed integer is undef (a: 1, b: -2)" ); my $s = $root->fetch_element('meet_test'); $result = $s->fetch; is( $result, undef, "test for undef variables in string" ); my ( $as, $bs ) = ( 'Linus', 'his penguin' ); $root->fetch_element('sav')->store($as); $root->fetch_element('sbv')->store($bs); $result = $s->fetch; is( $result, 'meet Linus and his penguin', "test result : computed string is '$result' (a: $as, b: $bs)" ); print "test allow_compute_override\n" if $trace; my $comp_over = $root->fetch_element('compute_with_override'); $bv->store(2); is( $comp_over->fetch, 3, "test computed value" ); $comp_over->store(4); is( $comp_over->fetch, 4, "test overridden value" ); my $cwu = $root->fetch_element('compute_with_upstream'); is( $cwu->fetch, undef, "test computed with upstream value" ); is( $cwu->fetch( mode => 'custom' ), undef, "test computed with upstream value (custom)" ); is( $cwu->fetch( mode => 'standard' ), 3, "test computed with upstream value (standard)" ); $cwu->store(4); is( $cwu->fetch, 4, "test overridden value" ); my $owv = $root->fetch_element('one_wrong_var'); eval { $owv->fetch; }; ok( $@, "expected failure with one_wrong_var" ); print "normal error:\n", $@, "\n" if $trace; my $cnv = $root->fetch_element('compute_no_var'); is( $cnv->fetch, 'compute_no_var', "test compute_no_var" ); my $foo2 = $root->fetch_element('foo2'); my $fen = $foo2->fetch_element('find_node_element_name'); ok( $fen, "created element find_node_element_name" ); is( $fen->fetch, 'foo2', "did find node element name" ); my $cen = $foo2->fetch_element('check_node_element_name'); ok( $cen, "created element check_node_element_name" ); is( $cen->fetch, 1, "did check node element name" ); my $slave_av = $root->fetch_element('bar')->fetch_element('av'); my $slave_bv = $root->fetch_element('bar')->fetch_element('bv'); is( $slave_av->fetch, $av->fetch, "compare slave av and av" ); is( $slave_bv->fetch, $bv->fetch, "compare slave bv and bv" ); $root->fetch_element('url')->store('http://foo.bar/baz.html'); my $h = $root->fetch_element('host'); is( $h->fetch, 'foo.bar', "check extracted host" ); $root->fetch_element( name => 'Maintainer', check => 'no' )->store_set( [qw/foo bar baz/] ); # reset to check if migration is seen as a change to be saved $inst->clear_changes; is( $inst->needs_save, 0, "check needs save before migrate" ); is( $root->grab_value( step => 'Upstream-Maintainer:0', check => 'no' ), 'foo', "check migrate_from first stage" ); is( $root->grab_value( step => 'Upstream-Contact:0' ), 'foo', "check migrate_from second stage" ); is( $inst->needs_save, 2, "check needs save before migrate" ); print join( "\n", $inst->list_changes("\n") ), "\n" if $trace; $root->fetch_element( name => 'Original-Source-Location', check => 'no' )->store('foobar'); is( $root->grab_value( step => 'Source' ), 'foobar', "check migrate_from with undef_is" ); my $v; warning_like { $v = $root->grab_value( step => 'Source2' ); }[ (qr/deprecated/) x 4 ], "check Source2 compute with undef_is"; is( $v, 'foobar', "check result of compute with undef_is" ); foreach (qw/bar foo2/) { my $path = "$_ location_function_in_formula"; is( $root->grab_value($path), $path, "check &location with $path" ); } # test formula with tmp variable my $tmph = $root->fetch_element('with_tmp_var'); is( $tmph->fetch, 'foo.bar', "check extracted host with temp variable" ); my $lic_gpl = $root->grab('Licenses:"GPL-1+"'); is( $lic_gpl->grab_value('text'), "yada yada GPL-1+\nyada yada", "check replacement with &index()" ); is( $root->grab_value('Licenses:PsF text'), "", "check missing replacement with &index()" ); is( $root->grab_value('Licenses:"MPL-1.1" text'), "", "check missing replacement with &index()" ); is( $root->grab_value('Licenses:"MPL-1.1" short_name_from_index'), "MPL-1.1", 'evaled &index($holder)' ); $root->load('index_function_target:foo name=Bond007'); is( $root->grab_value('test_index_function:foo name'), "Bond007 is my name", 'variable with &index(-)' ); $root->load( 'OtherMaintainer="Debian Ruby Extras Maintainers " Source=ruby-pygments.rb' ); is( $root->grab_value("Vcs-Browser"), 'http://anonscm.debian.org/gitweb/?p=pkg-ruby-extras/packages/ruby-pygments.rb.git', 'test compute with complex regexp formula' ); $root->load( 'OtherMaintainer="Debian Perl Group " Source=libconfig-model-perl' ); is( $root->grab_value("Vcs-Browser"), 'http://anonscm.debian.org/gitweb/?p=pkg-perl/packages/libconfig-model-perl.git', 'test compute with complex regexp formula' ); # Debian #810768, test a variable containing quote $root->load( q!OtherMaintainer="Bla Bla O'bla " Source=libconfig-model-perl! ); is( $root->grab_value("Vcs-Browser"), 'http://anonscm.debian.org/gitweb/?p=pkg-perl/packages/libconfig-model-perl.git', 'test compute with complex regexp formula' ); my $cwoaf = $root->fetch_element('compute_with_override_and_fix'); is($cwoaf->fetch, 'def value', "test compute_with_override_and_fix default value"); warning_like {$cwoaf->store('oops') ; }[ qr/not default value/], "check warning with modified compute_with_override_and_fix"; $cwoaf->apply_fixes; is($cwoaf->fetch, 'def value', "test compute_with_override_and_fix value after fix"); my $cwoapf = $root->fetch_element('compute_with_override_and_powerless_fix'); warning_like { $cwoapf->apply_fixes;} [ qr/not good value/], "check warning when applying powerless fix"; is($cwoapf->fetch, '/dev/lcd0', "test default value after powerless fix"); memory_cycle_ok( $model, "test memory cycles" ); done_testing; Config-Model-2.097/t/grab.t0000644000175000017500000000677513027007223014016 0ustar domidomi# -*- cperl -*- use ExtUtils::testlib; use Test::More tests => 42; use Test::Memory::Cycle; use Config::Model; use Log::Log4perl qw(:easy); use warnings; no warnings qw(once); use strict; use Data::Dumper; my $arg = shift || ''; my ( $log, $show ) = (0) x 3; my $do; my $trace = $arg =~ /t/ ? 1 : 0; $log = 1 if $arg =~ /l/; $show = 1 if $arg =~ /s/; Config::Model::Exception::Any->Trace(1) if $arg =~ /e/; my $home = $ENV{HOME} || ""; my $log4perl_user_conf_file = "$home/.log4config-model"; if ( $log and -e $log4perl_user_conf_file ) { Log::Log4perl::init($log4perl_user_conf_file); } else { Log::Log4perl->easy_init( $arg =~ /l/ ? $DEBUG : $WARN ); } my $model = Config::Model->new( legacy => 'ignore', ); ok( 1, "compiled" ); my $inst = $model->instance( root_class_name => 'Master', model_file => 't/big_model.pm', instance_name => 'test1' ); ok( $inst, "created dummy instance" ); my $root = $inst->config_root; Config::Model::Exception::Any->Trace(1) if $trace =~ /e/; my $step = 'std_id:ab X=Bv - std_id:bc X=Av - std_id:"b c" X=Av - a_string="titi , toto" '; ok( $root->load( step => $step ), "load '$step'" ); my $grabbed = $root->grab('olist:0'); is( $grabbed->location, 'olist:0', 'test grab olist:0 (obj)' ); is( $root->grab('olist:0')->index_value, 0, 'test grab olist:0 (index)' ); my $wp = 'olist:0'; eval { $root->grab( \$wp )->index_value; }; ok( $@, "Test grab with wrong parameter" ); print "normal error:\n", $@, "\n" if $trace; eval { $root->grab('std_xid:toto')->index_value; }; ok( $@, "Test grab with wrong element" ); print "normal error:\n", $@, "\n" if $trace; like( $root->grab('olist')->name, qr/olist/, 'test grab olist' ); is( $root->location(), '', 'location test' ); foreach my $wstep ( 'std_id:ab', 'olist:0', 'olist:1', 'warp', 'warp std_id:toto', 'warp std_id:"b c"' ) { my $obj = $root->grab($wstep); ok( $obj, "grab $wstep..." ); is( $obj->location, $wstep, "... and test its location" ); } print $root->dump_tree() if $trace =~ /t/; my $leaf = $root->grab('warp std_id:toto DX'); my @tests = ( [ '?warp', 'warp', 'WarpedNode' ], [ '?std_id:ab', 'warp std_id:ab', 'Node' ], [ '?hash_a:ab', 'hash_a:ab', 'Value' ], [ '?std_id', 'warp std_id', 'HashId' ], [ '!Master', '', 'Node' ], [ '!SlaveY', 'warp', 'Node' ], [ '!SlaveZ', 'warp std_id:toto', 'Node' ], ); foreach my $unit_test (@tests) { my $obj = $leaf->grab( $unit_test->[0] ); is( $obj->location, $unit_test->[1], "test grab with '$unit_test->[0]'" ); isa_ok( $obj, 'Config::Model::' . $unit_test->[2] ); } eval { $leaf->grab('?argh'); }; ok( $@, "test grab with wrong step: '?argh'" ); print "normal error:\n", $@, "\n" if $trace; eval { $root->grab( step => 'std_id:zzz', autoadd => 0 ); }; ok( $@, "test autoadd 0 with 'std_id:zzz'" ); print "normal error:\n", $@, "\n" if $trace; $root->grab( step => 'std_id:zzz', autoadd => 1 ); ok( 1, "test autoadd 1 with 'std_id:zzz'" ); my $obj = $root->grab( step => 'std_id:zzz foobar', mode => 'adaptative' ); is( $obj->location, "std_id:zzz", "test no strict grab" ); $obj = $root->grab( step => 'std_id:ab X', type => 'node', mode => 'adaptative' ); is( $obj->location, "std_id:ab", "test no strict grab with type node" ); eval { $root->grab( step => 'std_id:ab X', type => 'node', mode => 'strict' ); }; ok( $@, "test strict grab with type node" ); print "normal error:\n", $@, "\n" if $trace; memory_cycle_ok($model); Config-Model-2.097/t/hash_id_of_node.t0000644000175000017500000000727313027007223016165 0ustar domidomi# -*- cperl -*- use warnings; use ExtUtils::testlib; use Test::More tests => 18; use Test::Memory::Cycle; use Config::Model; use Data::Dumper; use Log::Log4perl qw(:easy :levels); use strict; my $arg = shift || ''; my ( $log, $show ) = (0) x 2; my $trace = $arg =~ /t/ ? 1 : 0; $log = 1 if $arg =~ /l/; $show = 1 if $arg =~ /s/; Log::Log4perl->easy_init( $log ? $TRACE : $WARN ); Config::Model::Exception::Any->Trace(1) if $arg =~ /e/; ok( 1, "Compilation done" ); my @element = ( # Value constructor args are passed in their specific array ref cargo => { type => 'node', config_class_name => 'Slave' }, ); # minimal set up to get things working my $model = Config::Model->new(); $model->create_config_class( name => "Master", element => [ 'plain_hash' => { type => 'hash', class => 'Config::Model::HashId', # default index_type => 'integer', @element }, 'bounded_hash' => { type => 'hash', class => 'Config::Model::HashId', # default index_type => 'integer', # hash boundaries min => 1, max => 123, max_nb => 2, @element }, 'hash_with_default_and_init' => { type => 'hash', index_type => 'string', default_with_init => { 'def_1' => 'X=Av Y=Bv', 'def_2' => 'Y=Av Z=Cv' }, @element }, ], ); $model->create_config_class( name => "Slave", element => [ [qw/X Y Z/] => { type => 'leaf', value_type => 'enum', choice => [qw/Av Bv Cv/] }, ] ); my $inst = $model->instance( root_class_name => 'Master', instance_name => 'test1' ); ok( $inst, "created dummy instance" ); my $root = $inst->config_root; my $b = $root->fetch_element('bounded_hash'); ok( $b, "bounded hash created" ); is( $b->name, 'Master bounded_hash id', "check hash id name" ); my $b1 = $b->fetch_with_id(1); isa_ok( $b1, 'Config::Model::Node', "fetched element id 1" ); is( $b1->config_class_name, 'Slave', 'check config_class_name' ); my $h_with_def = $root->fetch_element('hash_with_default_and_init'); my $res = [ $h_with_def->fetch_all_indexes ]; #print Dumper( $res ) ; is_deeply( $res, [qw/def_1 def_2/], 'check default items' ); #print $root->dump_tree ; is( $root->dump_tree, 'bounded_hash:1 - hash_with_default_and_init:def_1 X=Av Y=Bv - hash_with_default_and_init:def_2 Y=Av Z=Cv - - ', "check default items with children setup" ); is( $h_with_def->fetch_with_id('def_1')->index_value, 'def_1', 'check index_value prior to move' ); $h_with_def->move( 'def_1', 'moved_1' ); is( $h_with_def->fetch_with_id('moved_1')->index_value, 'moved_1', 'check index_value after move' ); $res = [ $h_with_def->fetch_all_indexes ]; is_deeply( $res, [qw/def_2 moved_1/], 'check moved items keys' ); #print $root->dump_tree ; is( $root->dump_tree, 'bounded_hash:1 - hash_with_default_and_init:def_2 Y=Av Z=Cv - hash_with_default_and_init:moved_1 X=Av Y=Bv - - ', "check moved items with children setup" ); $root->load("plain_hash:2 X=Av Y=Av Z=Cv"); my $ph = $root->fetch_element('plain_hash'); ok( $ph->copy( 2, 3 ), "node copy in hash" ); is( $ph->fetch_with_id(2)->dump_tree, $ph->fetch_with_id(3)->dump_tree, "compare copied values" ); ok( $ph->move( 2, 4 ), "node move in hash" ); is( $ph->fetch_with_id(4)->dump_tree, $ph->fetch_with_id(3)->dump_tree, "compare copied then moved values" ); is_deeply( [ $ph->fetch_all_indexes ], [ 3, 4 ], "compare indexes after move" ); memory_cycle_ok($model); Config-Model-2.097/t/backend_plainfile.t0000644000175000017500000000517313027007223016504 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 warnings; no warnings qw(once); use strict; use vars qw/$model/; $model = Config::Model->new(); my $arg = shift || ''; my $trace = $arg =~ /t/ ? 1 : 0; Config::Model::Exception::Any->Trace(1) if $arg =~ /e/; use Log::Log4perl qw(:easy); my $home = $ENV{HOME} || ""; my $log4perl_user_conf_file = "$home/.log4config-model"; if ( -e $log4perl_user_conf_file ) { Log::Log4perl::init($log4perl_user_conf_file); } else { Log::Log4perl->easy_init( $arg =~ /l/ ? $DEBUG : $WARN ); } ok( 1, "compiled" ); my $subdir = 'plain/'; $model->create_config_class( name => "WithPlainFile", element => [ [qw/source new/] => {qw/type leaf value_type uniline/}, clean => { qw/type list/, cargo => {qw/type leaf value_type uniline/} }, ], read_config => [ { backend => 'plain_file', config_dir => $subdir, }, ], ); # pseudo root where config files are written by config-model my $wr_root = 'wr_root/'; # cleanup before tests rmtree($wr_root); mkpath( $wr_root . $subdir, { mode => 0755 } ); my $fh = IO::File->new; $fh->open( $wr_root . $subdir . 'source', ">" ); $fh->print("2.0\n"); $fh->close; ok( 1, "wrote source file" ); $fh->open( $wr_root . $subdir . 'clean', ">" ); $fh->print("foo\n*/*/bar\n"); $fh->close; ok( 1, "wrote clean file" ); my $inst = $model->instance( root_class_name => 'WithPlainFile', root_dir => $wr_root, ); ok( $inst, "Created instance" ); my $root = $inst->config_root; is( $root->grab_value("source"), "2.0", "got correct source value" ); is( $root->grab_value("clean:0"), "foo", "got clean 0" ); is( $root->grab_value("clean:1"), "*/*/bar", "got clean 1" ); my $load = qq[source="3.0 (quilt)"\nnew="new stuff" clean:2="baz*"\n]; $root->load($load); $inst->write_back; ok( 1, "plain file write back done" ); my $new_file = $wr_root . 'plain/new'; ok( -e $new_file, "check that config file $new_file was written" ); is($root->grab('source')->backend_support_annotation(), 0, "check backend annotation support"); # create another instance to read the yaml that was just written my $i2_plain = $model->instance( instance_name => 'inst2', root_class_name => 'WithPlainFile', root_dir => $wr_root, ); ok( $i2_plain, "Created 2nd instance" ); my $i2_root = $i2_plain->config_root; my $p2_dump = $i2_root->dump_tree; is( $p2_dump, $root->dump_tree, "compare original data with 2nd instance data" ); memory_cycle_ok($model, "memory cycles"); done_testing; Config-Model-2.097/t/value.t0000644000175000017500000007212713027007223014211 0ustar domidomi# -*- cperl -*- use warnings; use 5.010; use ExtUtils::testlib; use Test::More; use Test::Exception; use Test::Warn; use Test::Differences; use Test::Memory::Cycle; use Config::Model; use Config::Model::Value; use Log::Log4perl qw(:easy :levels); use strict; binmode STDOUT, ':utf8'; my $arg = shift || ''; my ( $log, $show ) = (0) x 2; my $trace = $arg =~ /t/ ? 1 : 0; $log = 1 if $arg =~ /l/; $show = 1 if $arg =~ /s/; my $home = $ENV{HOME} || ""; my $log4perl_user_conf_file = "$home/.log4config-model"; if ( $log and -e $log4perl_user_conf_file ) { Log::Log4perl::init($log4perl_user_conf_file); } else { Log::Log4perl->easy_init( $log ? $WARN : $ERROR ); } Config::Model::Exception::Any->Trace(1) if $arg =~ /e/; ok( 1, "Compilation done" ); # minimal set up to get things working my $model = Config::Model->new(); $model->create_config_class( name => "BadClass", element => [ crooked => { type => 'leaf', class => 'Config::Model::Value', }, crooked_enum => { type => 'leaf', class => 'Config::Model::Value', value_type => 'enum', default => 'foo', choice => [qw/A B C/] }, ] ); $model->create_config_class( name => "Master", element => [ scalar => { type => 'leaf', class => 'Config::Model::Value', value_type => 'integer', min => 1, max => 4, }, string => { type => 'leaf', class => 'Config::Model::Value', value_type => 'string', }, bounded_number => { type => 'leaf', class => 'Config::Model::Value', value_type => 'number', min => 1, max => 4, }, mandatory_string => { type => 'leaf', class => 'Config::Model::Value', value_type => 'string', mandatory => 1, }, mandatory_boolean => { type => 'leaf', class => 'Config::Model::Value', value_type => 'boolean', mandatory => 1, }, mandatory_with_default_value => { type => 'leaf', class => 'Config::Model::Value', value_type => 'string', mandatory => 1, default => 'booya', }, boolean_with_write_as => { type => 'leaf', value_type => 'boolean', write_as => [qw/false true/], }, boolean_with_write_as_and_default => { type => 'leaf', value_type => 'boolean', write_as => [qw/false true/], default => 'true', }, bare_enum => { type => 'leaf', class => 'Config::Model::Value', value_type => 'enum', choice => [qw/A B C/] }, enum => { type => 'leaf', class => 'Config::Model::Value', value_type => 'enum', default => 'A', choice => [qw/A B C/] }, enum_with_help => { type => 'leaf', class => 'Config::Model::Value', value_type => 'enum', choice => [qw/a b c/], help => { a => 'a help' } }, uc_convert => { type => 'leaf', class => 'Config::Model::Value', value_type => 'string', convert => 'uc', }, lc_convert => { type => 'leaf', class => 'Config::Model::Value', value_type => 'string', convert => 'lc', }, upstream_default => { type => 'leaf', value_type => 'string', upstream_default => 'up_def', }, a_uniline => { type => 'leaf', value_type => 'uniline', upstream_default => 'a_uniline_def', }, with_replace => { type => 'leaf', value_type => 'enum', choice => [qw/a b c/], replace => { a1 => 'a', c1 => 'c', 'foo/.*' => 'b', }, }, replacement_hash => { type => 'hash', index_type => 'string', cargo => { type => 'leaf', value_type => 'uniline', }, }, with_replace_follow => { type => 'leaf', value_type => 'string', replace_follow => '- replacement_hash', }, match => { type => 'leaf', value_type => 'string', match => '^foo\d{2}/$', }, prd_test_action => { type => 'leaf', value_type => 'string', }, prd_match => { type => 'leaf', value_type => 'string', grammar => q^check: check: token (oper token)(s?) oper: 'and' | 'or' token: 'Apache' | 'CC-BY' | 'Perl' { my $v = $arg[0]->grab("! prd_test_action")->fetch || ''; $failed++ unless $v =~ /$item[1]/ ; } ^, }, warn_if_match => { type => 'leaf', value_type => 'string', warn_if_match => { 'foo' => { fix => '$_ = uc;' } }, }, warn_unless_match => { type => 'leaf', value_type => 'string', warn_unless_match => { foo => { msg => '', fix => '$_ = "foo".$_;' } }, }, assert => { type => 'leaf', value_type => 'string', assert => { assert_test => { code => 'defined $_ and /\w/', msg => 'must not be empty', fix => '$_ = "foobar";' } }, }, warn_if_number => { type => 'leaf', value_type => 'string', warn_if => { warn_test => { code => 'defined $_ && /\d/;', msg => 'should not have numbers', fix => 's/\d//g;' } }, }, warn_unless => { type => 'leaf', value_type => 'string', warn_unless => { warn_test => { code => 'defined $_ and /\w/', msg => 'should not be empty', fix => '$_ = "foobar";' } }, }, always_warn => { type => 'leaf', value_type => 'string', warn => 'Always warn whenever used', }, 'Standards-Version' => { 'value_type' => 'uniline', 'warn_unless_match' => { '3\\.9\\.2' => { 'msg' => 'Current standard version is 3.9.2', 'fix' => '$_ = undef; #restore default' } }, 'match' => '\\d+\\.\\d+\\.\\d+(\\.\\d+)?', 'default' => '3.9.2', 'type' => 'leaf', }, t_file => { type => 'leaf', value_type => 'file' }, t_dir => { type => 'leaf', value_type => 'dir' } ], # dummy class ); my $bad_inst = $model->instance( root_class_name => 'BadClass', instance_name => 'test_bad_class' ); ok( $bad_inst, "created bad_class instance" ); $bad_inst->initial_load_stop; my $bad_root = $bad_inst->config_root; my $result; throws_ok { $bad_root->fetch_element('crooked'); } 'Config::Model::Exception::Model', "test create expected failure"; print "normal error:\n", $@, "\n" if $trace; my $inst = $model->instance( root_class_name => 'Master', instance_name => 'test1' ); ok( $inst, "created dummy instance" ); $inst->initial_load_stop; sub check_store_error { my ( $obj, $v, $qr ) = @_; my $path = $obj->location; $obj->store( value => $v, silent => 1, check => 'skip' ); is( $inst->errors->{$path}, '', "store error in $path is tracked" ); like( scalar $inst->error_messages, $qr, "check $path error message" ); } sub check_error { my ( $obj, $v, $qr ) = @_; my $old_v = $obj->fetch; check_store_error(@_); is( $obj->fetch, $old_v, "check that wrong value $v was not stored" ); } my $root = $inst->config_root; note "test simple scalar"; { 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" ); 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; } note "test bounded number"; { 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" ); } note "test mandatory string"; { 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; } note "test mandatory string provided with a default value"; { 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; } note "test mandatory boolean"; { 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/ ); my @bool_test = ( 1, 1, yes => 1, Yes => 1, no => 0, Nope => 0, true => 1, False => 0 ); while (@bool_test) { my $store = shift @bool_test; my $read = shift @bool_test; $mb->store($store); is( $mb->fetch, $read, "mandatory boolean: store $store and read $read value" ); } } note "test boolean where values are translated to true/false"; { $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: '' -> '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" ); } { 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; } note "test enum"; { 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" ); } note "test uppercase conversion"; { 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" ); } note "test lowercase conversion"; { 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" ); } note "Testing integrated help"; { 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" ); } note "Testing upstream default value"; { 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"); } note "test uniline type"; { 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" ); } note "testing replace feature"; { my $wrepl = $root->fetch_element('with_replace'); $wrepl->store('c1'); is( $wrepl->fetch, "c", "tested replaced value" ); $wrepl->store('foo/bar'); is( $wrepl->fetch, "b", "tested replaced value with regexp" ); } note "test preset feature"; { my $pinst = $model->instance( root_class_name => 'Master', instance_name => 'preset_test' ); ok( $pinst, "created dummy preset instance" ); my $p_root = $pinst->config_root; $pinst->preset_start; ok( $pinst->preset, "instance in preset mode" ); my $p_scalar = $p_root->fetch_element('scalar'); $p_scalar->store(3); my $p_enum = $p_root->fetch_element('enum'); $p_enum->store('B'); $pinst->preset_stop; is( $pinst->preset, 0, "instance in normal mode" ); is( $p_scalar->fetch, 3, "scalar: read preset value as value" ); $p_scalar->store(4); is( $p_scalar->fetch, 4, "scalar: read overridden preset value as value" ); is( $p_scalar->fetch('preset'), 3, "scalar: read preset value as preset_value" ); is( $p_scalar->fetch_standard, 3, "scalar: read preset value as standard_value" ); is( $p_scalar->fetch_custom, 4, "scalar: read custom_value" ); is( $p_enum->fetch, 'B', "enum: read preset value as value" ); $p_enum->store('C'); is( $p_enum->fetch, 'C', "enum: read overridden preset value as value" ); is( $p_enum->fetch('preset'), 'B', "enum: read preset value as preset_value" ); is( $p_enum->fetch_standard, 'B', "enum: read preset value as standard_value" ); is( $p_enum->fetch_custom, 'C', "enum: read custom_value" ); is( $p_enum->default, 'A', "enum: read default_value" ); } note "test layered feature"; { my $layer_inst = $model->instance( root_class_name => 'Master', instance_name => 'layered_test' ); ok( $layer_inst, "created dummy layered instance" ); my $l_root = $layer_inst->config_root; $layer_inst->layered_start; ok( $layer_inst->layered, "instance in layered mode" ); my $l_scalar = $l_root->fetch_element('scalar'); $l_scalar->store(3); my $l_enum = $l_root->fetch_element('bare_enum'); $l_enum->store('B'); my $msl = $l_root->fetch_element('mandatory_string'); $msl->store('plop'); $layer_inst->layered_stop; is( $layer_inst->layered, 0, "instance in normal mode" ); is( $l_scalar->fetch, undef, "scalar: read layered value as backend value" ); is( $l_scalar->fetch( mode => 'user' ), 3, "scalar: read layered value as user value" ); is( $l_scalar->has_data, 0, "scalar: has no data" ); $l_scalar->store(4); is( $l_scalar->fetch, 4, "scalar: read overridden layered value as value" ); is( $l_scalar->fetch('layered'), 3, "scalar: read layered value as layered_value" ); is( $l_scalar->fetch_standard, 3, "scalar: read standard_value" ); is( $l_scalar->fetch_custom, 4, "scalar: read custom_value" ); is( $l_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"); } note "test match regexp"; { my $match = $root->fetch_element('match'); check_error( $match, 'bar', qr/does not match/ ); $match->store('foo42/'); is( $match->fetch, 'foo42/', "test stored matching value" ); } note "test validation done with a Parse::RecDescent grammar"; { 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" ); } } note "test warn_if_match with a string"; { my $wim = $root->fetch_element('warn_if_match'); warning_like { $wim->store('foobar'); } qr/should not match/, "test warn_if condition"; is( $wim->has_fixes, 1, "test has_fixes" ); 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" ); } note "test warn_if_match with a regexp"; { my $win = $root->fetch_element('warn_if_number'); warning_like { $win->store('bar51'); } qr/should not have numbers/, "test warn_if condition"; is( $win->has_fixes, 1, "test has_fixes" ); $win->apply_fixes; is( $win->fetch, 'bar', "test if fixes were applied" ); } note "test warn_unless_match feature"; { my $wup = $root->fetch_element('warn_unless_match'); warning_like { $wup->store('bar'); } qr/should match/, "test warn_unless_match condition"; is( $wup->has_fixes, 1, "test has_fixes" ); $wup->apply_fixes; is( $wup->fetch, 'foobar', "test if fixes were applied" ); } note "test unconditional feature"; { my $aw = $root->fetch_element('always_warn'); warning_like { $aw->store('whatever'); } qr/always/i, "got unconditional warning"; } note "test unicode"; { 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; note "test replace_follow"; { my $wrf = $root->fetch_element('with_replace_follow'); $inst->clear_changes; $wrf->store('foo'); is( $inst->needs_save, 1, "check needs_save after store" ); $inst->clear_changes; is( $wrf->fetch, 'foo', "check replacement_hash with foo (before replacement)" ); is( $inst->needs_save, 0, "check needs_save after simple fetch" ); $root->load('replacement_hash:foo=repfoo replacement_hash:bar=repbar'); is( $inst->needs_save, 2, "check needs_save after load" ); $inst->clear_changes; is( $wrf->fetch, 'repfoo', "check replacement_hash with foo (after replacement)" ); is( $inst->needs_save, 1, "check needs_save after fetch with replacement" ); $wrf->store('bar'); is( $wrf->fetch, 'repbar', "check replacement_hash with bar" ); $wrf->store('baz'); is( $wrf->fetch, 'baz', "check replacement_hash with baz (no replacement)" ); ok( !$root->fetch_element('replacement_hash')->exists('baz'), "check that replacement hash was not changed by missed substitution" ); $inst->clear_changes; } { my $sv = $root->fetch_element('Standards-Version'); warning_like { $sv->store('3.9.1'); } qr/Current/, "store old standard version"; is( $inst->needs_save, 1, "check needs_save after load" ); $sv->apply_fixes; is( $inst->needs_save, 2, "check needs_save after load" ); print join( "\n", $inst->list_changes("\n") ), "\n" if $trace; is( $sv->fetch, '3.9.2', "check fixed standard version" ); is( $sv->fetch( mode => 'custom' ), undef, "check custom standard version" ); } note "test assert"; { my $assert_elt = $root->fetch_element('assert'); throws_ok { $assert_elt->fetch(); } 'Config::Model::Exception::WrongValue', "check assert error"; $assert_elt->apply_fixes; ok( 1, "assert_elt apply_fixes called" ); is( $assert_elt->fetch, 'foobar', "check fixed assert pb" ); } note "test warn_unless"; { my $warn_unless = $root->fetch_element('warn_unless'); warning_like { $warn_unless->fetch(); } qr/should not be empty/, "check warn_unless"; $warn_unless->apply_fixes; ok( 1, "warn_unless apply_fixes called" ); is( $warn_unless->fetch, 'foobar', "check fixed warn_unless pb" ); } note "test file and dir value types" ; { my $t_file = $root->fetch_element('t_file'); my $t_dir = $root->fetch_element('t_dir'); warning_like {$t_file->store('toto')} qr/not exist/, "test non existent file" ; warning_like {$t_file->store('t')} qr/not a file/, "test not a file" ; warning_like {$t_dir->store('t/value.t')} qr/not a dir/, "test not a dir" ; $t_file->store('t/value.t') ; is($t_file->has_warning, 0, "test a file"); $t_dir->store('t/') ; is($t_dir->has_warning, 0, "test a dir"); } note "test problems during initial load"; { my $inst2 = $model->instance( root_class_name => 'Master', instance_name => 'initial_test' ); ok( $inst2, "created initial_test inst2ance" ); # is triggered internally only when at least one node has a RW backend $inst2->initial_load_start; my $s = $inst2->config_root->fetch_element('string'); $s->store('foo'); $s->store('foo'); is( $inst2->needs_save, 1, "verify instance needs_save status after redundant data" ); eq_or_diff([$inst2->list_changes],['string: removed redundant initial value'],"check change message for redundant data"); $inst2->clear_changes; is( $inst2->needs_save, 0, "needs_save after clearing changes" ); $s->store('bar'); eq_or_diff([$inst2->list_changes],['string: \'foo\' -> \'bar\' # conflicting initial values'],"check change message for redundant data"); is( $inst2->needs_save, 1, "verify instance needs_save status after conflicting data" ); $inst2->clear_changes; $s->parent->fetch_element('uc_convert')->store('foo'); eq_or_diff([$inst2->list_changes],['uc_convert: \'foo\' -> \'FOO\' # initial value changed by model'], "check change message when model changes data coming from config file"); $inst2->clear_changes; $s->parent->fetch_element('boolean_with_write_as')->store('true'); is( $inst2->needs_save, 0, "verify instance needs_save status after writing 'boolean_with_write_as'" ); $inst2->initial_load_stop; } memory_cycle_ok( $model, "check memory cycles" ); done_testing; Config-Model-2.097/weaver.ini0000644000175000017500000000022513027007223014425 0ustar domidomi[@Default] [-Transformer] transformer = List [Support] perldoc = 0 bugs = metadata websites = search,anno,ratings,kwalitee,testers,testmatrix,deps Config-Model-2.097/Changes0000644000175000017500000032701413027007223013736 0ustar domidomi2.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.097/lib/0000755000175000017500000000000013027007223013202 5ustar domidomiConfig-Model-2.097/lib/Config/0000755000175000017500000000000013027007223014407 5ustar domidomiConfig-Model-2.097/lib/Config/Model/0000755000175000017500000000000013027007223015447 5ustar domidomiConfig-Model-2.097/lib/Config/Model/system.d/0000755000175000017500000000000013027007223017215 5ustar domidomiConfig-Model-2.097/lib/Config/Model/system.d/popcon0000644000175000017500000000001713027007223020434 0ustar domidomimodel = PopCon Config-Model-2.097/lib/Config/Model/system.d/fstab0000644000175000017500000000001613027007223020234 0ustar domidomimodel = Fstab Config-Model-2.097/lib/Config/Model/Report.pm0000644000175000017500000001237513027007223017270 0ustar domidomi# # This file is part of Config-Model # # This software is Copyright (c) 2005-2016 by Dominique Dumont. # # This is free software, licensed under: # # The GNU Lesser General Public License, Version 2.1, February 1999 # package Config::Model::Report; $Config::Model::Report::VERSION = '2.097'; use Carp; use strict; use warnings; use Config::Model::Exception; use Config::Model::ObjTreeScanner; use Text::Wrap; sub new { bless {}, shift; } sub report { my $self = shift; my %args = @_; my $audit = delete $args{audit} || 0; my $node = delete $args{node} || croak "dump_tree: missing 'node' parameter"; my $std_cb = sub { my ( $scanner, $data_r, $obj, $element, $index, $value_obj ) = @_; # if element is a collection, get the value pointed by $index $value_obj = $obj->fetch_element($element)->fetch_with_id($index) if defined $index; # get value or only customized value my $value = $audit ? $value_obj->fetch_custom : $value_obj->fetch; $value = '"' . $value . '"' if defined $value and $value =~ /\s/; if ( defined $value ) { my $name = defined $index ? " $element:$index" : $element; push @$data_r, $obj->location . " $name = $value"; my $desc = $obj->get_help_as_text($element); if ( defined $desc and $desc ) { push @$data_r, wrap( "\t", "\t\t", "DESCRIPTION: $desc" ); } my $effect = $value_obj->get_help_as_text($value); if ( defined $effect and $effect ) { push @$data_r, wrap( "\t", "\t\t", "SELECTED: $effect" ); } push @$data_r, ''; # to get empty line in report } }; my @scan_args = ( fallback => 'all', auto_vivify => 0, leaf_cb => $std_cb, ); my @left = keys %args; croak "Report: unknown parameter:@left" if @left; # perform the scan my $view_scanner = Config::Model::ObjTreeScanner->new(@scan_args); my @ret; $view_scanner->scan_node( \@ret, $node ); return join( "\n", @ret ); } 1; # ABSTRACT: Reports data from config tree __END__ =pod =encoding UTF-8 =head1 NAME Config::Model::Report - Reports data from config tree =head1 VERSION version 2.097 =head1 SYNOPSIS use Config::Model; # define configuration tree object my $model = Config::Model->new; $model->create_config_class( name => "Foo", element => [ [qw/foo bar/] => { type => 'leaf', value_type => 'string' }, ], description => [ foo => 'some foo explanation', bar => 'some bar explanation', ] ); $model->create_config_class( name => "MyClass", element => [ [qw/foo bar/] => { type => 'leaf', value_type => 'string' }, my_enum => { type => 'leaf', value_type => 'enum', choice => [qw/A B C/], help => { A => 'first letter', B => 'second letter', C => 'third letter', }, description => 'some letters', }, hash_of_nodes => { type => 'hash', # hash id index_type => 'string', cargo => { type => 'node', config_class_name => 'Foo' }, }, ], ); my $inst = $model->instance(root_class_name => 'MyClass' ); my $root = $inst->config_root ; # put data my $steps = 'foo=FOO my_enum=B hash_of_nodes:fr foo=bonjour - hash_of_nodes:en foo=hello '; $root->load( steps => $steps ); print $root->report ; # foo = FOO # # my_enum = B # DESCRIPTION: some letters # SELECTED: second letter # # hash_of_nodes:en foo = hello # DESCRIPTION: some foo explanation # # hash_of_nodes:fr foo = bonjour # DESCRIPTION: some foo explanation =head1 DESCRIPTION This module is used directly by L to provide a human readable report of the configuration. This report includes the configuration values and (if provided by the model) the description of the configuration item and their effect. A C shows C configuration items. An C shows only configuration items which are different from their default value. =head1 CONSTRUCTOR =head2 new ( ) No parameter. The constructor should be used only by L. =head1 Methods =head2 report Returns a string containing the configuration values and (if provided by the model) the description of the configuration item and their effect. Parameters are: =over =item audit Set to 1 to report only configuration data different from default values. Default is 0. =item node Reference to the L object that is dumped. All nodes and leaves attached to this node are also dumped. =back =head1 AUTHOR Dominique Dumont, (ddumont at cpan dot org) =head1 SEE ALSO L,L,L =head1 AUTHOR Dominique Dumont =head1 COPYRIGHT AND LICENSE This software is Copyright (c) 2005-2016 by Dominique Dumont. This is free software, licensed under: The GNU Lesser General Public License, Version 2.1, February 1999 =cut Config-Model-2.097/lib/Config/Model/IdElementReference.pm0000644000175000017500000002535113027007223021500 0ustar domidomi# # This file is part of Config-Model # # This software is Copyright (c) 2005-2016 by Dominique Dumont. # # This is free software, licensed under: # # The GNU Lesser General Public License, Version 2.1, February 1999 # package Config::Model::IdElementReference; $Config::Model::IdElementReference::VERSION = '2.097'; use Mouse; use Carp; use Config::Model::ValueComputer; use Log::Log4perl qw(get_logger :levels); my $logger = get_logger("Tree::Element::IdElementReference"); # config_elt is a reference to the object that called new has config_elt => ( is => 'ro', isa => 'Config::Model::AnyThing', required => 1, weak_ref => 1 ); has refer_to => ( is => 'ro', isa => 'Maybe[Str]' ); has computed_refer_to => ( is => 'ro', isa => 'Maybe[HashRef]' ); sub BUILD { my $self = shift; my $found = scalar grep { defined $self->$_; } qw/refer_to computed_refer_to/; if ( not $found ) { Config::Model::Exception::Model->throw( object => $self->config_elt, message => "missing " . "refer_to or computed_refer_to parameter" ); } elsif ( $found > 1 ) { Config::Model::Exception::Model->throw( object => $self->config_elt, message => "cannot specify both " . "refer_to and computed_refer_to parameters" ); } my $rft = $self->{refer_to}; my $crft = $self->{computed_refer_to} || {}; my %c_args = %$crft; my $refer_path = defined $rft ? $rft : delete $c_args{formula}; # split refer_path on + then create as many ValueComputer as # required my @references = split /\s+\+\s+/, $refer_path; foreach my $single_path (@references) { push @{ $self->{compute} }, Config::Model::ValueComputer->new( formula => $single_path, variables => {}, %c_args, value_object => $self->{config_elt}, value_type => 'string' # a reference is always a string ); } return $self; } # internal # FIXME: do not call back value object -> may recurse sub get_choice_from_refered_to { my $self = shift; my $config_elt = $self->{config_elt}; my @enum_choice = $config_elt->get_default_choice; foreach my $compute_obj ( @{ $self->{compute} } ) { my $user_spec = $compute_obj->compute; next unless defined $user_spec; my @path = split( /\s+/, $user_spec ); $logger->debug("path: @path"); my $refered_to = eval { $config_elt->grab("@path"); }; if (ref $@) { my $e = $@; # don't use $e->full_description as it will recurse badly Config::Model::Exception::Model->throw( object => $config_elt, error => "'refer_to' parameter with path '@path': " .$e->description ); } my $element = pop @path; my $obj = $refered_to->parent; my $type = $obj->element_type($element); my @choice; if ( $type eq 'check_list' ) { @choice = $obj->fetch_element($element)->get_checked_list(); } elsif ( $type eq 'hash' ) { @choice = $obj->fetch_element($element)->fetch_all_indexes(); } elsif ( $type eq 'list' ) { my $list_obj = $obj->fetch_element($element); my $ct = $list_obj->get_cargo_type; if ( $ct eq 'leaf' ) { @choice = $list_obj->fetch_all_values( mode => 'user' ); } else { Config::Model::Exception::Model->throw( object => $obj, message => "element '$element' cargo_type is $ct. " . "Expected 'leaf'" ); } } else { Config::Model::Exception::Model->throw( object => $obj, message => "element '$element' type is $type. " . "Expected hash or list or check_list" ); } # use a hash so choices are unique push @enum_choice, @choice; } # prune out repeated items my %h; my @unique = grep { my $found = $h{$_} || 0; $h{$_} = 1; not $found; } @enum_choice; my @res; if ( $config_elt->value_type eq 'check_list' and $config_elt->ordered ) { @res = @unique; } else { @res = sort @unique; } $logger->debug( "Setting choice to '", join( "','", @res ), "'" ); $config_elt->setup_reference_choice(@res); } sub reference_info { my $self = shift; my $str = "choice was retrieved with: "; foreach my $compute_obj ( @{ $self->{compute} } ) { my $path = $compute_obj->formula; $path = defined $path ? "'$path'" : 'undef'; $str .= "\n\tpath $path"; $str .= "\n\t" . $compute_obj->compute_info; } return $str; } sub compute_obj { my $self = shift; return @{ $self->{compute} }; } sub reference_path { my $self = shift; return map { $_->formula } @{ $self->{compute} }; } __PACKAGE__->meta->make_immutable; 1; # ABSTRACT: Refer to id element(s) and extract keys __END__ =pod =encoding UTF-8 =head1 NAME Config::Model::IdElementReference - Refer to id element(s) and extract keys =head1 VERSION version 2.097 =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 refered_to hash element or the values of the refered_to array element. The example means the the value must correspond to an existing host: value_type => 'reference', refer_to => '! host' This example means the the value must correspond to an existing lan within the host whose Id is specified by hostname: value_type => 'reference', computed_refer_to => { formula => '! host:$a lan', variables => { a => '- hostname' } } If you need to combine possibilities from several hash, use the "C<+>" token to separate 2 paths: value_type => 'reference', computed_refer_to => { formula => '! host:$a lan + ! host:foobar lan', variables => { a => '- hostname' } } You can specify C or C with a C argument so the possible enum value will be the combination of the specified choice and the refered_to values. =head1 Methods =head2 reference_info Returns a human readable string with explains how is retrieved the reference. This method is mostly used to construct an error messages. =head1 AUTHOR Dominique Dumont, (ddumont at cpan dot org) =head1 SEE ALSO L, L, L, L =head1 AUTHOR Dominique Dumont =head1 COPYRIGHT AND LICENSE This software is Copyright (c) 2005-2016 by Dominique Dumont. This is free software, licensed under: The GNU Lesser General Public License, Version 2.1, February 1999 =cut Config-Model-2.097/lib/Config/Model/BackendMgr.pm0000644000175000017500000011134013027007223020002 0ustar domidomi# # This file is part of Config-Model # # This software is Copyright (c) 2005-2016 by Dominique Dumont. # # This is free software, licensed under: # # The GNU Lesser General Public License, Version 2.1, February 1999 # package Config::Model::BackendMgr; $Config::Model::BackendMgr::VERSION = '2.097'; use Mouse; use Carp; use 5.10.1; use Config::Model::Exception; use Data::Dumper; use File::Path; use File::Copy; use File::HomeDir; use IO::File; use Storable qw/dclone/; use Scalar::Util qw/weaken/; use Log::Log4perl qw(get_logger :levels); my $logger = get_logger('BackendMgr'); # used only for tests my $__test_home = ''; sub _set_test_home { $__test_home = shift; } # one BackendMgr per file has 'node' => ( is => 'ro', isa => 'Config::Model::Node', weak_ref => 1, required => 1 ); has 'file_backup' => ( is => 'rw', isa => 'ArrayRef', default => sub { [] } ); has 'backend' => ( is => 'rw', isa => 'HashRef[Config::Model::Backend::Any]', traits => ['Hash'], default => sub { {} }, handles => { set_backend => 'set', get_backend => 'get' } ); # Configuration directory where to read and write files. This value # does not override the configuration directory specified in the model # data passed to read and write functions. has config_dir => ( is => 'ro', isa => 'Maybe[Str]', required => 0 ); has support_annotation => ( is => 'ro', isa => 'Bool', default => 0, ); sub get_tuned_config_dir { my ($self, %args) = @_; my $dir = $args{os_config_dir}{$^O} || $args{config_dir} || $self->config_dir || ''; if ( $dir =~ /^~/ ) { my $home = $__test_home || File::HomeDir->my_home; $dir =~ s/^~/$home/; } $dir .= '/' if $dir and $dir !~ m(/$); return $dir; } sub get_cfg_dir_path { my $self = shift; my %args = @_; my $w = $args{write} || 0; my $dir = $self->get_tuned_config_dir(%args); $dir = $args{root} . $dir; if ( not -d $dir and $w and $args{auto_create} ) { $logger->info("creating directory $dir"); mkpath( $dir, 0, 0755 ); } unless ( -d $dir ) { $logger->info( "auto_" . ( $w ? 'write' : 'read' ) . " $args{backend} no directory $dir" ); return ( 0, $dir ); } $logger->debug( "dir: " . $dir // '' ); return ( 1, $dir ); } sub get_cfg_file_path { my $self = shift; my %args = @_; my $w = $args{write} || 0; # config file override my $cfo = $args{config_file}; if ( defined $cfo and $cfo eq '-' and $w == 0 ) { $logger->trace("auto_read: $args{backend} override target file is STDIN"); return ( 1, '-' ); } if ( defined $cfo ) { my $override = $args{root} . $args{config_file}; $logger->trace( "auto_" . ( $w ? 'write' : 'read' ) . " $args{backend} override target file is $override" ); return ( 1, $args{root} . $args{config_file} ); } Config::Model::Exception::Model->throw( error => "backend error: empty 'config_dir' parameter (and no config_file override)", object => $self->node ) unless $args{config_dir} or $self->config_dir; my ( $dir_ok, $dir ) = $self->get_cfg_dir_path(%args); if ( defined $args{file} ) { my $file = $args{file}; $file =~ s/&index/$self->node->index_value/eg; my $res = $dir . $file; $logger->trace("get_cfg_file_path: returns $res"); return ( $dir_ok, $res ); } if ( not defined $args{suffix} ) { $logger->trace("get_cfg_file_path: returns undef (no suffix, no file argument)"); return (0); } my $i = $self->node->instance; my $name = $dir . $i->name; # append ":foo bar" if not root object my $loc = $self->node->location; # not very good if ($loc) { if ( ( $w and not -d $name and $args{auto_create} ) ) { $logger->info( "get_cfg_file_path: auto_write create subdirectory ", "$name (location $loc)" ); mkpath( $name, 0, 0755 ); } $name .= '/' . $loc; } $name .= $args{suffix}; $logger->trace( "get_cfg_file_path: auto_" . ( $w ? 'write' : 'read' ) . " $args{backend} target file is $name" ); return ( 1, $name ); } sub open_read_file { my $self = shift; my %args = @_; my ( $file_ok, $file_path ) = $self->get_cfg_file_path(%args); if ( $file_ok and $file_path eq '-' ) { my $io = IO::Handle->new(); if ( $io->fdopen( fileno(STDIN), "r" ) ) { return ( 1, '-', $io ); } else { return ( 0, '-' ); } } # not very clean return ( 0, $file_path ) if $args{backend} =~ /_file$/ and ( not $file_ok or not -r $file_path ); my $fh = new IO::File; if ( $file_ok and -e $file_path ) { $logger->debug("open_read_file: open $file_path for read"); $fh->open($file_path); $fh->binmode(":utf8"); # store a backup in memory in case there's a problem $self->file_backup( [ $fh->getlines ] ); $fh->seek( 0, 0 ); # go back to beginning of file return ( 1, $file_path, $fh ); } else { return ( 0, $file_path ); } } # called at configuration node creation # # New subroutine "load_backend_class" extracted - Thu Aug 12 18:32:37 2010. # sub load_backend_class { my $backend = shift; my $function = shift; $logger->debug("load_backend_class: called with backend $backend, function $function"); my %c; my $k = "Config::Model::Backend::" . ucfirst($backend); my $f = $k . '.pm'; $f =~ s!::!/!g; $c{$k} = $f; # try another class $k =~ s/_(\w)/uc($1)/ge; $f =~ s/_(\w)/uc($1)/ge; $c{$k} = $f; foreach my $c ( keys %c ) { if ( $c->can($function) ) { # no need to load class $logger->debug("load_backend_class: $c is already loaded (can $function)"); return $c; } } # look for file to load my $class_to_load; foreach my $c ( keys %c ) { $logger->debug("load_backend_class: looking to load class $c"); foreach my $prefix (@INC) { my $realfilename = "$prefix/$c{$c}"; $class_to_load = $c if -f $realfilename; } } return unless defined $class_to_load; my $file_to_load = $c{$class_to_load}; $logger->debug("load_backend_class: loading class $class_to_load, $file_to_load"); eval { require $file_to_load; }; if ($@) { die "Could not parse $file_to_load: $@\n"; } return $class_to_load; } sub read_config_data { my ( $self, %args ) = @_; { no warnings 'uninitialized'; $logger->debug( "called with ", join( ' ', %args ) ); } my $readlist_orig = delete $args{read_config}; my $check = delete $args{check}; my $r_dir = delete $args{read_config_dir}; my $config_file_override = delete $args{config_file}; my $auto_create_override = delete $args{auto_create}; croak "unexpected args " . join( ' ', keys %args ) . "\n" if %args; # r_dir is obsolete if ( defined $r_dir ) { die $self->node->config_class_name, " : read_config_dir is obsolete\n"; } my $readlist = dclone $readlist_orig ; my $instance = $self->node->instance(); # root override is passed by the instance my $root_dir = $instance->read_root_dir || ''; croak "readlist must be array or hash ref\n" unless ref $readlist; my @list = ref $readlist eq 'ARRAY' ? @$readlist : ($readlist); my $pref_backend = $instance->backend || ''; my $read_done = 0; my $auto_create = 0; my @tried; foreach my $read (@list) { warn $self->config_class_name, " deprecated 'syntax' parameter in backend\n" if defined $read->{syntax}; my $backend = delete $read->{backend} || delete $read->{syntax} || 'custom'; if ( $backend =~ /^(perl|ini|cds)$/ ) { warn $self->config_class_name, " deprecated backend $backend. Should be '$ {backend}_file'\n"; $backend .= "_file"; } next if ( $pref_backend and $backend ne $pref_backend ); if ( defined $read->{allow_empty} ) { warn "backend $backend: allow_empty is deprecated. Use auto_create"; $auto_create ||= delete $read->{allow_empty}; } $auto_create ||= delete $read->{auto_create} if defined $read->{auto_create}; if ( $read->{default_layer} ) { $self->read_config_sub_layer( $read, $root_dir, $config_file_override, $check, $backend ); } my ( $res, $file ) = $self->try_read_backend( $read, $root_dir, $config_file_override, $check, $backend ); push @tried, $file; if ($res) { $read_done = 1; last; } } Config::Model::Exception::ConfigFile::Missing->throw( tried_files => \@tried, object => $self->node, ) unless $read_done or $auto_create_override or $auto_create; } sub read_config_sub_layer { my ( $self, $read, $root_dir, $config_file_override, $check, $backend ) = @_; my $layered_config = delete $read->{default_layer}; my $layered_read = dclone $read ; map { my $lc = delete $layered_config->{$_}; $layered_read->{$_} = $lc if $lc; } qw/file config_dir os_config_dir/; Config::Model::Exception::Model->throw( error => "backend error: unexpected default_layer parameters: " . join( ' ', keys %$layered_config ), object => $self->node, ) if %$layered_config; my $i = $self->node->instance; my $already_in_layered = $i->layered; # layered stuff here if ( not $already_in_layered ) { $i->layered_clear; $i->layered_start; } $self->try_read_backend( $layered_read, $root_dir, $config_file_override, $check, $backend ); if ( not $already_in_layered ) { $i->layered_stop; } } # called at configuration node creation, NOT when writing # # New subroutine "try_read_backend" extracted - Sun Jul 14 11:52:58 2013. # sub try_read_backend { my $self = shift; my $read = shift; my $root_dir = shift; my $config_file_override = shift; my $check = shift; my $backend = shift; my $read_dir = $self->get_tuned_config_dir(%$read); my @read_args = ( %$read, root => $root_dir, config_dir => $read_dir, backend => $backend, check => $check, config_file => $config_file_override ); my ( $file_ok, $res, $fh, $file_path ); if ( $backend eq 'custom' ) { my $c = my $file = delete $read->{class}; $file =~ s!::!/!g; my $f = delete $read->{function} || 'read'; require $file . '.pm' unless $c->can($f); no strict 'refs'; $logger->info("Read with custom backend $ {c}::$f in dir $read_dir"); ( $file_ok, $file_path, $fh ) = $self->open_read_file(@read_args); eval { $res = &{ $c . '::' . $f }( @read_args, file_path => $file_path, io_handle => $fh, object => $self->node ); }; } elsif ( $backend eq 'perl_file' ) { ( $file_ok, $file_path, $fh ) = $self->open_read_file( @read_args, suffix => '.pl' ); return ( 0, $file_path ) unless $file_ok; eval { $res = $self->read_perl( @read_args, file_path => $file_path, io_handle => $fh ); }; } elsif ( $backend eq 'cds_file' ) { ( $file_ok, $file_path, $fh ) = $self->open_read_file( @read_args, suffix => '.cds' ); return ( 0, $file_path ) unless $file_ok; eval { $res = $self->read_cds_file( @read_args, file_path => $file_path, io_handle => $fh, ); }; } else { # try to load a specific Backend class my $f = delete $read->{function} || 'read'; my $c = load_backend_class( $backend, $f ); return ( 0, 'unknown' ) unless defined $c; no strict 'refs'; my $backend_obj = $c->new( node => $self->node, name => $backend ); $self->set_backend( $backend => $backend_obj ); my $suffix; $suffix = $backend_obj->suffix if $backend_obj->can('suffix'); ( $file_ok, $file_path, $fh ) = $self->open_read_file( @read_args, suffix => $suffix ); if ($logger->is_info) { my $fp = defined $file_path ? " on $file_path":'' ; $logger->info( "Read with $backend " . $c . "::$f".$fp); } eval { $res = $backend_obj->$f( @read_args, file_path => $file_path, io_handle => $fh, object => $self->node, ); }; # only backend based on C::M::Backend::Any can support annotations if ($backend_obj->can('annotation')) { $self->{support_annotation} ||= $backend_obj->annotation ; } } # catch eval errors done in the if-then-else block before my $e = $@; if ( ref($e) and $e->isa('Config::Model::Exception::Syntax') ) { $e->parsed_file( $file_path) unless $e->parsed_file; $e->rethrow; } elsif ( ref $e ) { $e->rethrow ; } elsif ( $e ) { die "Backend error: $e"; } return ( $res, $file_path ); } sub auto_write_init { my ( $self, %args ) = @_; my $wrlist_orig = delete $args{write_config}; my $w_dir = delete $args{write_config_dir}; weaken($self); # avoid leak: $self is stored in write_back closure croak "auto_write_init: unexpected args " . join( ' ', keys %args ) . "\n" if %args; # w_dir is obsolete if ( defined $w_dir ) { die $self->config_class_name, " : write_config_dir is obsolete\n"; } my $wrlist = dclone $wrlist_orig ; my $instance = $self->node->instance(); # root override is passed by the instance my $root_dir = $instance->write_root_dir || ''; my @array = ref $wrlist eq 'ARRAY' ? @$wrlist : ($wrlist); # ensure that one auto_create specified applies to all wr backends my $auto_create = 0; foreach my $write (@array) { $auto_create ||= delete $write->{auto_create} if defined $write->{auto_create}; } # provide a proper write back function foreach my $write (@array) { warn $self->config_class_name, " deprecated 'syntax' parameter in auto_write\n" if defined $write->{syntax}; my $backend = delete $write->{backend} || delete $write->{syntax} || 'custom'; if ( $backend =~ /^(perl|ini|cds)$/ ) { warn $self->config_class_name, " deprecated backend $backend. Should be '$ {backend}_file'\n"; $backend .= "_file"; } my $write_dir = $self->get_tuned_config_dir(%$write); $logger->debug( "auto_write_init creating write cb ($backend) for ", $self->node->name ); my @wr_args = ( %$write, # model data auto_create => $auto_create, backend => $backend, config_dir => $write_dir, # override from instance write => 1, # for get_cfg_file_path root => $root_dir, # override from instance ); my $wb; if ( $backend eq 'custom' ) { my $c = my $file = $write->{class}; $file =~ s!::!/!g; my $f = $write->{function} || 'write'; require $file . '.pm' unless $c->can($f); $wb = sub { no strict 'refs'; $logger->debug( "write cb ($backend) called for ", $self->node->name ); my ( $file_ok, $file_path, $fh ) = $self->open_file_to_write( $backend, @wr_args, @_ ) unless ( $c->can('skip_open') and $c->skip_open ); my $res; $res = eval { # override needed for "save as" button &{ $c . '::' . $f }( @wr_args, io_handle => $fh, file_path => $file_path, conf_dir => $write_dir, # legacy FIXME object => $self->node, @_ # override from user ); }; $logger->warn( "write backend $c" . '::' . "$f failed: $@" ) if $@; $self->close_file_to_write( $@, $fh, $file_path ); return defined $res ? $res : $@ ? 0 : 1; }; $self->{auto_write}{custom} = 1; } elsif ( $backend eq 'perl_file' ) { $wb = sub { $logger->debug( "write cb ($backend) called for ", $self->node->name ); my ( $file_ok, $file_path, $fh ) = $self->open_file_to_write( $backend, suffix => '.pl', @wr_args, @_ ); my $res; $res = eval { $self->write_perl( @wr_args, io_handle => $fh, file_path => $file_path, @_ ); }; $self->close_file_to_write( $@, $fh, $file_path ); $logger->warn("write backend $backend failed: $@") if $@; return defined $res ? $res : $@ ? 0 : 1; }; $self->{auto_write}{perl_file} = 1; } elsif ( $backend eq 'cds_file' ) { $wb = sub { $logger->debug( "write cb ($backend) called for ", $self->node->name ); my ( $file_ok, $file_path, $fh ) = $self->open_file_to_write( $backend, suffix => '.cds', @wr_args, @_ ); my $res; $res = eval { $self->write_cds_file( @wr_args, io_handle => $fh, file_path => $file_path, @_ ); }; $logger->warn("write backend $backend failed: $@") if $@; $self->close_file_to_write( $@, $fh, $file_path ); return defined $res ? $res : $@ ? 0 : 1; }; $self->{auto_write}{cds_file} = 1; } else { my $f = $write->{function} || 'write'; my $c = load_backend_class( $backend, $f ); $wb = sub { no strict 'refs'; $logger->debug( "write cb ($backend) called for ", $self->node->name ); my $backend_obj = $self->get_backend($backend) || $c->new( node => $self->node, name => $backend ); my $suffix = $backend_obj->suffix if $backend_obj->can('suffix'); my ( $file_ok, $file_path, $fh ) = $self->open_file_to_write( $backend, suffix => $suffix, @wr_args, @_ ) unless ( $c->can('skip_open') and $c->skip_open ); # override needed for "save as" button my %backend_args = ( @wr_args, io_handle => $fh, file_path => $file_path, object => $self->node, @_ # override from user ); my $res = eval { $backend_obj->$f( %backend_args ); }; $logger->warn( "write backend $backend $c" . '::' . "$f failed: $@" ) if $@; $self->close_file_to_write( $@, $fh, $file_path ); $self->auto_delete($file_path, \%backend_args) if $write->{auto_delete}; return defined $res ? $res : $@ ? 0 : 1; }; } # FIXME: enhance write back mechanism so that different backend *and* different nodes # work as expected $logger->debug( "registering write $backend in node " . $self->node->name ); push @{ $self->{write_back} }, [ $backend, $wb ]; $instance->register_write_back( $self->node->location ); } } sub auto_delete { my ($self, $file_path, $args) = @_; my $perl_data = $self->node->dump_as_data( full_dump => $args->{full_dump} // 0); my $size = ref($perl_data) eq 'HASH' ? scalar keys %$perl_data : ref($perl_data) eq 'ARRAY' ? scalar @$perl_data : $perl_data ; if (not $size) { $logger->info( "Removing $file_path (no data to store)" ); unlink($file_path); } } sub write_back { my $self = shift; my %args = @_; my $force_backend = delete $args{backend} || ''; croak "write_back: no subs registered in node", $self->node->location, ". cannot save data\n" unless @{ $self->{write_back} }; my @backends = @{ $self->{write_back} }; $logger->debug( "write_back called on node '", $self->node->name, "' for ", scalar @backends, " backends" ); my $dir = $args{config_dir}; mkpath( $dir, 0, 0755 ) if $dir and not -d $dir; foreach my $wb_info (@backends) { my ( $backend, $wb ) = @$wb_info; if ( not $force_backend or $force_backend eq $backend or $force_backend eq 'all' ) { # exit when write is successfull my $res = $wb->(%args); $logger->info( "write_back called with $backend backend, result is ", defined $res ? $res : '' ); last if ( $res and not $force_backend ); } } $logger->debug( "write_back on node '", $self->node->name, "' done" ); } sub open_file_to_write { my ( $self, $backend, %args ) = @_; my $backup = delete $args{backup}; my $do_backup = defined $backup; $backup ||= 'old'; # use old only if defined $backup = '.' . $backup unless $backup =~ /^\./; my ( $file_ok, $file_path ) = $self->get_cfg_file_path(%args); if ( $file_ok and $file_path eq '-' ) { my $io = IO::Handle->new(); if ( $io->fdopen( fileno(STDOUT), "w" ) ) { return ( 1, '-', $io ); } else { return ( 0, '-' ); } } elsif ($file_ok) { if ( $do_backup and -r $file_path ) { copy( $file_path, $file_path . $backup ) or die "Backup copy failed: $!"; } $logger->debug("$backend backend opened file $file_path to write"); my $fh = new IO::File; $fh->open("> $file_path") || die "Cannot open $file_path:$!"; $fh->binmode(':utf8'); return ( $file_ok, $file_path, $fh ); } else { return ( 0, $file_path ); } } sub close_file_to_write { my ( $self, $error, $fh, $file_path ) = @_; return unless defined $file_path; if ($error) { # restore backup and display error my $data = $self->file_backup; $logger->debug( "Error during write, restoring backup in $file_path with " . scalar @$data . " lines" ); $fh->seek( 0, 0 ); # go back to beginning of file $fh->print(@$data); $fh->close; $error->rethrow if ref($error) and $error->can('rethrow'); die $error; } $fh->close; # check file size and remove empty files unlink($file_path) 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; } sub read_cds_file { my $self = shift; my %args = @_; my $file_path = $args{file_path}; $logger->info("Read cds data from $file_path"); $self->node->load( step => [ $args{io_handle}->getlines ] ); return 1; } sub write_cds_file { my $self = shift; my %args = @_; my $file_path = $args{file_path}; $logger->info("Write cds data to $file_path"); my $dump = $self->node->dump_tree( skip_auto_write => 'cds_file', check => $args{check} ); $args{io_handle}->print($dump); return 1; } sub read_perl { my $self = shift; my %args = @_; my $file_path = $args{file_path}; $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_perl { my $self = shift; my %args = @_; my $file_path = $args{file_path}; $logger->info("Write perl data to $file_path"); my $p_data = $self->node->dump_as_data( skip_auto_write => 'perl_file', check => $args{check} ); my $dumper = Data::Dumper->new( [$p_data] ); $dumper->Terse(1); $args{io_handle}->print( $dumper->Dump, ";\n" ); return 1; } __PACKAGE__->meta->make_immutable; 1; # ABSTRACT: Load configuration node on demand __END__ =pod =encoding UTF-8 =head1 NAME Config::Model::BackendMgr - Load configuration node on demand =head1 VERSION version 2.097 =head1 SYNOPSIS # Use BackendMgr to write data in Yaml file use Config::Model; # define configuration tree object my $model = Config::Model->new; $model->create_config_class( name => "Foo", element => [ [qw/foo bar/] => { type => 'leaf', value_type => 'string' }, ] ); $model->create_config_class( name => "MyClass", # read_config spec is used by Config::Model::BackendMgr read_config => [ { backend => '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 node or on this backend manager). =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. =item * C: specifies a dedicated class and function to read and load the configuration tree. This is provided for backward compatibility and should not be used for new projects. =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 for its data to be read and saved. When needed (usually for the root node), the configuration class is declared with a C parameter. This parameter is a list of possible backend. Usually, only one read backend is needed. =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 custom 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 custom 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: 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 Alternatively, C can be set to C<->, in which case, the configuration is read from STDIN. =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: read_config => [ { backend => 'IniFile', config_dir => '/tmp', file => 'foo.conf', auto_create => 1 } ], Setting C to 1 is necessary to create a configuration from scratch When C is set in write backend, missing directory and files are created with current umask. Default is false. =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: read_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. =head2 Built-in backend C and C backend must be specified with mandatory C parameter. For instance: read_config => { backend => 'cds_file' , config_dir => '/etc/cfg_dir', file => 'cfg_file.cds', #optional }, When C is not specified, a file name is constructed with C<< . >> where suffix is C or C. =head2 Custom backend Custom backend is provided to be backward compatible but should not be used for new project. L is preferred. Custom backend must be specified with a class name that features the methods used to write and read the configuration files: read_config => [ { backend => 'custom' , class => 'MyRead', function => 'read_it", # optional, defaults to 'read' config_dir => '/etc/foo', # optional file => 'foo.conf', # optional } ] C backend parameters are: =over =item class Specify the class that contains the read methods =item function Function name that is called back to read the file. See L for details. (default is C) =item file optional. Configuration file. This parameter may not apply if the configuration is stored in several files. By default, the instance name is used as configuration file name. =back Most of the times, there's no need to create a write specification: the read specification is enough for this module to write back the configuration file. The write method must be specified if the writer class is not the same as the reader class or if the writer method is not C: write_config => [ { backend => 'custom' , class => 'MyWrite', function => 'write_it", # optional, defaults to 'read' config_dir => '/etc/foo', # optional file => 'foo.conf', # optional } ] Read callback function is called with these parameters: object => $obj, # Config::Model::Node object root => './my_test', # fake root directory, used for tests config_dir => /etc/foo', # absolute path file => 'foo.conf', # file name file_path => './my_test/etc/foo/foo.conf' io_handle => $io # IO::File object with binmode :utf8 check => [yes|no|skip] The L object is undef if the file cannot be read. The callback must return 0 on failure and 1 on successful read. Write callback function is called with these parameters: object => $obj, # Config::Model::Node object root => './my_test', # fake root directory, used for tests config_dir => /etc/foo', # absolute path file => 'foo.conf', # file name file_path => './my_test/etc/foo/foo.conf' io_handle => $io # IO::File object opened in write mode # with binmode :utf8 auto_create => 1 # create dir as needed check => [yes|no|skip] The L object is undef if the file cannot be written to. The callback must return 0 on failure and 1 on successful write. =head1 Using backend to change configuration file syntax C tries all the specified backends. This feature can be used to migrate from one syntax to another. In this example, backend manager first tries to read an INI file and then to read a YAML file: read_config => [ { backend => 'IniFile', ... }, { backend => 'yaml', ... }, ], When a read operation is successful, the remaining read methods are skipped. Likewise, the C specification accepts several backends. By default, the specifications are tried in order, until the first succeeds. In the example above, the migration from INI to YAML can be achieved by specifying only the YAML backend: write_config => [ { backend => 'yaml', ... }, ], =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 CAVEATS When both C and C are specified, this class write-opens the configuration file (and thus clobber it) before calling the C call-back and pass the file handle with C parameter. C should use this handle to write data in the target configuration file. If this behavior causes problem (e.g. with augeas backend), the solution is either to set C to undef or an empty string in the C specification. =head1 Methods =head2 write_back ( ... ) Try to run all subroutines registered by L write the configuration information until one succeeds (returns true). You can specify here a pseudo root directory or another config directory to write configuration data back with C and C parameters. This overrides the model specifications. You can force to use a backend by specifying C<< backend => xxx >>. For instance, C<< backend => 'perl_file' >> or C<< backend => 'custom' >>. You can force to use all backend to write the files by specifying C<< backend => 'all' >>. You can force a specific config file to write with C<< config_file => 'foo/bar.conf' >> C croaks if no write call-back are known for this node. =head2 support_annotation Returns 1 if at least one of the backends support to read and write annotations (aka comments) in the configuration file. =head1 AUTHOR Dominique Dumont, (ddumont at cpan dot org) =head1 SEE ALSO L, L, L, L =head1 AUTHOR Dominique Dumont =head1 COPYRIGHT AND LICENSE This software is Copyright (c) 2005-2016 by Dominique Dumont. This is free software, licensed under: The GNU Lesser General Public License, Version 2.1, February 1999 =cut Config-Model-2.097/lib/Config/Model/Describe.pm0000644000175000017500000002340113027007223017525 0ustar domidomi# # This file is part of Config-Model # # This software is Copyright (c) 2005-2016 by Dominique Dumont. # # This is free software, licensed under: # # The GNU Lesser General Public License, Version 2.1, February 1999 # package Config::Model::Describe; $Config::Model::Describe::VERSION = '2.097'; 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; map { $scanner->scan_element( $data_ref, $node, $_ ) } @scan; }; my $std_cb = sub { my ( $scanner, $data_r, $obj, $element, $index, $value_obj ) = @_; my $value = $value_obj->fetch( check => $check ); return unless $show_empty or (defined $value and length($value)); $value = '"' . $value . '"' if defined $value and $value =~ /\s/; #print "DEBUG: std_cb on $element, idx $index, value $value\n"; my $name = defined $index ? "$element:$index" : $element; $value = defined $value ? $value : '[undef]'; my $type = $value_obj->value_type; my @comment; push @comment, "choice: " . join( ' ', @{ $value_obj->choice } ) if $type eq 'enum'; push @comment, 'mandatory' if $value_obj->mandatory; $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) { map { $scanner->scan_hash( $data_r, $obj, $element, $_ ) } @keys; } 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>", '' ]; #$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.097 =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-2016 by Dominique Dumont. This is free software, licensed under: The GNU Lesser General Public License, Version 2.1, February 1999 =cut Config-Model-2.097/lib/Config/Model/HashId.pm0000644000175000017500000004073413027007223017155 0ustar domidomi# # This file is part of Config-Model # # This software is Copyright (c) 2005-2016 by Dominique Dumont. # # This is free software, licensed under: # # The GNU Lesser General Public License, Version 2.1, February 1999 # package Config::Model::HashId; $Config::Model::HashId::VERSION = '2.097'; use Mouse; use 5.10.1; use Config::Model::Exception; use Carp; use Mouse::Util::TypeConstraints; subtype 'HaskKeyArray' => as 'ArrayRef' ; coerce 'HaskKeyArray' => from 'Str' => via { [$_] } ; use Log::Log4perl qw(get_logger :levels); my $logger = get_logger("Tree::Element::Id::Hash"); extends qw/Config::Model::AnyId/; with "Config::Model::Role::Grab"; has data => ( is => 'rw', isa => 'HashRef', default => sub { {}; } ); has list => ( is => 'rw', isa => 'ArrayRef[Str]', traits => ['Array'], default => sub { []; }, handles => { _sort => 'sort_in_place', } ); has [qw/default_keys auto_create_keys/] => ( is => 'rw', isa => 'HaskKeyArray', coerce => 1, default => sub { []; } ); has [qw/morph ordered/] => ( is => 'ro', isa => 'Bool' ); sub BUILD { my $self = shift; # foreach my $wrong (qw/migrate_values_from/) { # Config::Model::Exception::Model->throw ( # object => $self, # error => "Cannot use $wrong with ".$self->get_type." element" # ) if defined $self->{$wrong}; # } # could use "required", but we'd get a Moose error instead of a Config::Model # error Config::Model::Exception::Model->throw( object => $self, error => "Undefined index_type" ) unless defined $self->index_type; return $self; } sub set_properties { my $self = shift; $self->SUPER::set_properties(@_); my $idx_type = $self->{index_type}; # remove unwanted items my $data = $self->{data}; my $idx = 1; my $wrong = sub { my $k = shift; if ( $idx_type eq 'integer' ) { return 1 if defined $self->{max_index} and $k > $self->{max_index}; return 1 if defined $self->{min_index} and $k < $self->{min_index}; } return 1 if defined $self->{max_nb} and $idx++ > $self->{max_nb}; return 0; }; # delete entries that no longer fit the constraints imposed by the # warp mechanism foreach my $k ( sort keys %$data ) { next unless $wrong->($k); $logger->debug( "set_properties: ", $self->name, " deleting id $k" ); delete $data->{$k}; } } sub _migrate { my $self = shift; return if $self->{migration_done}; # migration must be done *after* initial load to make sure that all data # were retrieved from the file before migration. return if $self->instance->initial_load; $self->{migration_done} = 1; if ( $self->{migrate_keys_from} ) { my $followed = $self->safe_typed_grab( param => 'migrate_keys_from', check => 'no' ); if ( $logger->is_debug ) { $logger->debug( $self->name, " migrate keys from ", $followed->name ); } map { $self->_store( $_, undef ) unless $self->_defined($_) } $followed->fetch_all_indexes; } elsif ( $self->{migrate_values_from} ) { my $followed = $self->safe_typed_grab( param => 'migrate_values_from', check => 'no' ); $logger->debug( $self->name, " migrate values from ", $followed->name ) if $logger->is_debug; foreach my $item ( $followed->fetch_all_indexes ) { next if $self->exists($item); # don't clobber existing entries my $data = $followed->fetch_with_id($item)->dump_as_data( check => 'no' ); $self->fetch_with_id($item)->load_data($data); } } } sub get_type { my $self = shift; return 'hash'; } # important: return the actual size (not taking into account auto-created stuff) sub fetch_size { my $self = shift; return scalar keys %{ $self->{data} }; } sub _fetch_all_indexes { my $self = shift; return $self->{ordered} ? @{ $self->{list} } : sort keys %{ $self->{data} }; } # fetch without any check sub _fetch_with_id { my ( $self, $key ) = @_; my $i = $self->instance; return $self->{data}{$key}; } # store without any check sub _store { my ( $self, $key, $value ) = @_; push @{ $self->{list} }, $key unless exists $self->{data}{$key}; return $self->{data}{$key} = $value; } sub _exists { my ( $self, $key ) = @_; return exists $self->{data}{$key}; } sub _defined { my ( $self, $key ) = @_; return defined $self->{data}{$key} ? 1 : 0; } #internal sub auto_create_elements { my $self = shift; my $auto_p = $self->auto_create_keys; return unless defined $auto_p; # create empty slots map { $self->_store( $_, undef ) unless exists $self->{data}{$_}; } ( ref $auto_p ? @$auto_p : ($auto_p) ); } # internal sub create_default { my $self = shift; my @temp = keys %{ $self->{data} }; return if @temp; # hash is empty so create empty element for default keys my $def = $self->get_default_keys; map { $self->_store( $_, undef ) } @$def; $self->create_default_with_init; } sub _delete { my ( $self, $key ) = @_; # remove key in ordered list @{ $self->{list} } = grep { $_ ne $key } @{ $self->{list} }; return delete $self->{data}{$key}; } sub remove { my $self = shift; $self->delete(@_); } sub _clear { my ($self) = @_; $self->{list} = []; $self->{data} = {}; } sub sort { my $self = shift; if ($self->ordered) { $self->_sort; } else { Config::Model::Exception::User->throw( object => $self, message => "cannot call sort on non ordered hash" ); } } sub insort { my ($self, $id) = @_; if ($self->ordered) { my $elt = $self->fetch_with_id($id); $self->_sort; return $elt; } else { Config::Model::Exception::User->throw( object => $self, message => "cannot call insort on non ordered hash" ); } } # hash only method sub firstkey { my $self = shift; $self->warp if ( $self->{warp} and @{ $self->{warp_info}{computed_master} } ); $self->create_default if defined $self->{default}; # reset "each" iterator (to be sure, map is also an iterator) my @list = $self->_fetch_all_indexes; $self->{each_list} = \@list; return shift @list; } # hash only method sub nextkey { my $self = shift; $self->warp if ( $self->{warp} and @{ $self->{warp_info}{computed_master} } ); my $res = shift @{ $self->{each_list} }; return $res if defined $res; # reset list for next call to next_keys $self->{each_list} = [ $self->_fetch_all_indexes ]; return; } sub swap { my $self = shift; my ( $key1, $key2 ) = @_; foreach my $k (@_) { Config::Model::Exception::User->throw( object => $self, message => "swap: unknow key $k" ) unless exists $self->{data}{$k}; } my @copy = @{ $self->{list} }; for ( my $idx = 0 ; $idx <= $#copy ; $idx++ ) { if ( $copy[$idx] eq $key1 ) { $self->{list}[$idx] = $key2; } if ( $copy[$idx] eq $key2 ) { $self->{list}[$idx] = $key1; } } $self->notify_change( note => "swap ordered hash keys '$key1' and '$key2'" ); } sub move { my $self = shift; my ( $from, $to, %args ) = @_; Config::Model::Exception::User->throw( object => $self, message => "move: unknow key $from" ) unless exists $self->{data}{$from}; my $ok = $self->check_idx($to); my $check = $args{check}; if ($ok or $check eq 'no') { # this may clobber the old content of $self->{data}{$to} $self->{data}{$to} = delete $self->{data}{$from}; delete $self->{warning_hash}{$from}; # update index_value attribute in moved objects $self->{data}{$to}->index_value($to); $self->notify_change( note => "rename key from '$from' to '$to'" ); # data_mode is preset or layered or user. Actually only user # mode makes sense here my $imode = $self->instance->get_data_mode; $self->set_data_mode( $to, $imode ); my ( $to_idx, $from_idx ); my $idx = 0; my $list = $self->{list}; map { $to_idx = $idx if $list->[$idx] eq $to; $from_idx = $idx if $list->[$idx] eq $from; $idx++; } @$list; if ( defined $to_idx ) { # Since $to is clobbered, $from takes its place in the list $list->[$from_idx] = $to; # and the $from entry is removed from the list splice @$list, $to_idx, 1; } else { # $to is moved in the place of from in the list $list->[$from_idx] = $to; } } elsif ($check eq 'yes') { Config::Model::Exception::WrongValue->throw( error => join( "\n\t", @{ $self->{error} } ), object => $self ); } $logger->debug("Skipped move $from -> $to"); return $ok; } sub move_after { my $self = shift; my ( $key_to_move, $ref_key ) = @_; if ( not $self->ordered ) { $logger->warn("called move_after on unordered hash"); return; } foreach my $k (@_) { Config::Model::Exception::User->throw( object => $self, message => "swap: unknow key $k" ) unless exists $self->{data}{$k}; } # remove the key to move in ordered list @{ $self->{list} } = grep { $_ ne $key_to_move } @{ $self->{list} }; my $list = $self->{list}; my $msg; if ( defined $ref_key ) { for ( my $idx = 0 ; $idx <= $#$list ; $idx++ ) { if ( $list->[$idx] eq $ref_key ) { splice @$list, $idx + 1, 0, $key_to_move; last; } } $msg = "moved key '$key_to_move' after '$ref_key'"; } else { unshift @$list, $key_to_move; $msg = "moved key '$key_to_move' at beginning"; } $self->notify_change( note => $msg ); } sub move_up { my $self = shift; my ($key) = @_; if ( not $self->ordered ) { $logger->warn("called move_up on unordered hash"); return; } Config::Model::Exception::User->throw( object => $self, message => "move_up: unknow key $key" ) unless exists $self->{data}{$key}; my $list = $self->{list}; # we start from 1 as we can't move up idx 0 for ( my $idx = 1 ; $idx < scalar @$list ; $idx++ ) { if ( $list->[$idx] eq $key ) { $list->[$idx] = $list->[ $idx - 1 ]; $list->[ $idx - 1 ] = $key; $self->notify_change( note => "moved up key '$key'" ); last; } } # notify_change is placed in the loop so the notification # is not sent if the user tries to move up idx 0 } sub move_down { my $self = shift; my ($key) = @_; if ( not $self->ordered ) { $logger->warn("called move_down on unordered hash"); return; } Config::Model::Exception::User->throw( object => $self, message => "move_down: unknown key $key" ) unless exists $self->{data}{$key}; my $list = $self->{list}; # we end at $#$list -1 as we can't move down last idx for ( my $idx = 0 ; $idx < scalar @$list - 1 ; $idx++ ) { if ( $list->[$idx] eq $key ) { $list->[$idx] = $list->[ $idx + 1 ]; $list->[ $idx + 1 ] = $key; $self->notify_change( note => "moved down key $key" ); last; } } # notify_change is placed in the loop so the notification # is not sent if the user tries to move past last idx } sub load_data { my $self = shift; my %args = @_ > 1 ? @_ : ( data => shift ); my $data = delete $args{data}; my $check = $self->_check_check( $args{check} ); if ( ref($data) eq 'HASH' ) { my @load_keys; my $from = ''; my $order_key = '__'.$self->element_name.'_order'; if ( $self->{ordered} and (defined $data->{$order_key} or defined $data->{__order} )) { @load_keys = @{ delete $data->{$order_key} or delete $data->{__order} }; $from = ' with '.$order_key; } elsif ( $self->{ordered} ) { $logger->warn( "HashId " . $self->location . ": loading ordered " . "hash from hash ref without special key '__order'. Element " . "order is not defined" ); $from = ' without '.$order_key; } @load_keys = sort keys %$data unless @load_keys; $logger->info( "HashId load_data (" . $self->location . ") will load idx @load_keys from hash ref" . $from ); foreach my $elt (@load_keys) { my $obj = $self->fetch_with_id($elt); $obj->load_data( %args, data => $data->{$elt} ); } } elsif ( ref($data) eq 'ARRAY' ) { $logger->info( "HashId load_data (" . $self->location . ") will load idx 0..$#$data from array ref" ); $self->notify_change( note => "Converted ordered data to non ordered", really => 1) unless $self->ordered; my $idx = 0; while ( $idx < @$data ) { my $elt = $data->[ $idx++ ]; my $obj = $self->fetch_with_id($elt); $obj->load_data( %args, data => $data->[ $idx++ ] ); } } elsif ( defined $data ) { # we can skip undefined data my $expected = $self->{ordered} ? 'array' : 'hash'; Config::Model::Exception::LoadData->throw( object => $self, message => "load_data called with non $expected ref arg", wrong_data => $data, ); } } __PACKAGE__->meta->make_immutable; 1; # ABSTRACT: Handle hash element for configuration model __END__ =pod =encoding UTF-8 =head1 NAME Config::Model::HashId - Handle hash element for configuration model =head1 VERSION version 2.097 =head1 SYNOPSIS See L =head1 DESCRIPTION This class provides hash elements for a L. The hash index can either be en enumerated type, a boolean, an integer or a string. =head1 CONSTRUCTOR HashId object should not be created directly. =head1 Hash model declaration See L from L. =head1 Methods =head2 get_type Returns C. =head2 fetch_size Returns the number of elements of the hash. =head2 sort Sort an ordered hash. Throws an error if called on a non ordered hash. =head2 insort Parameters: key Create a new element in the ordered hash while keeping alphabetical order of the keys Returns the newly created element. Throws an error if called on a non ordered hash. =head2 firstkey Returns the first key of the hash. Behaves like C core perl function. =head2 nextkey Returns the next key of the hash. Behaves like C core perl function. =head2 swap ( key1 , key2 ) Swap the order of the 2 keys. Ignored for non ordered hash. =head2 move ( key1 , key2 ) Rename key1 in key2. Also also optional check parameter to disable warning: move ('foo','bar', check => 'no') =head2 move_after ( key_to_move [ , after_this_key ] ) Move the first key after the second one. If the second parameter is omitted, the first key is placed in first position. Ignored for non ordered hash. =head2 move_up ( key ) Move the key up in a ordered hash. Attempt to move up the first key of an ordered hash is ignored. Ignored for non ordered hash. =head2 move_down ( key ) Move the key down in a ordered hash. Attempt to move up the last key of an ordered hash is ignored. Ignored for non ordered hash. =head2 load_data ( data => ( hash_ref | array_ref ) [ , check => ... , ... ]) Load check_list as a hash ref for standard hash. Ordered hash should be loaded with an array ref or with a hash containing a special C<__order> element. E.g. loaded with either: [ a => 'foo', b => 'bar' ] or { __order => ['a','b'], b => 'bar', a => 'foo' } load_data can also be called with a single ref parameter. =head1 AUTHOR Dominique Dumont, (ddumont at cpan dot org) =head1 SEE ALSO L, L, L, L, L =head1 AUTHOR Dominique Dumont =head1 COPYRIGHT AND LICENSE This software is Copyright (c) 2005-2016 by Dominique Dumont. This is free software, licensed under: The GNU Lesser General Public License, Version 2.1, February 1999 =cut Config-Model-2.097/lib/Config/Model/Cookbook/0000755000175000017500000000000013027007223017215 5ustar domidomiConfig-Model-2.097/lib/Config/Model/Cookbook/CreateModelFromDoc.pod0000644000175000017500000002206413027007223023363 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.097 =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 at config-model-users at lists dot sourceforge dot net. =head1 AUTHORS Dominique Dumont =head1 AUTHOR Dominique Dumont =head1 COPYRIGHT AND LICENSE This software is Copyright (c) 2005-2016 by Dominique Dumont. This is free software, licensed under: The GNU Lesser General Public License, Version 2.1, February 1999 =cut Config-Model-2.097/lib/Config/Model/Value.pm0000644000175000017500000023605613027007223017075 0ustar domidomi# # This file is part of Config-Model # # This software is Copyright (c) 2005-2016 by Dominique Dumont. # # This is free software, licensed under: # # The GNU Lesser General Public License, Version 2.1, February 1999 # package Config::Model::Value; $Config::Model::Value::VERSION = '2.097'; use 5.10.1; use Mouse; use Mouse::Util::TypeConstraints; use MouseX::StrictConstructor; use Parse::RecDescent 1.90.0; use Data::Dumper (); use Config::Model::Exception; use Config::Model::ValueComputer; use Config::Model::IdElementReference; use Config::Model::Warper; use Log::Log4perl qw(get_logger :levels); use Scalar::Util qw/weaken/; use Carp; use Storable qw/dclone/; use Path::Tiny; use List::MoreUtils qw(any) ; extends qw/Config::Model::AnyThing/; with "Config::Model::Role::WarpMaster"; with "Config::Model::Role::Grab"; with "Config::Model::Role::HelpAsText"; my $logger = get_logger("Tree::Element::Value"); my $change_logger = get_logger("Anything::Change"); my $fix_logger = get_logger("Anything::Fix"); our $nowarning = 0; # global variable to silence warnings. Only used for tests enum ValueType => qw/boolean enum uniline string integer number reference file dir/; has fixes => ( is => 'rw', isa => 'ArrayRef', default => sub { [] } ); has [qw/warp compute computed_refer_to backup migrate_from/] => ( is => 'rw', isa => 'Maybe[HashRef]' ); has compute_obj => ( is => 'ro', isa => 'Maybe[Config::Model::ValueComputer]', builder => '_build_compute_obj', lazy => 1 ); has [qw/write_as/] => ( is => 'rw', isa => 'Maybe[ArrayRef]' ); has [qw/refer_to _data replace_follow/] => ( is => 'rw', isa => 'Maybe[Str]' ); has value_type => ( is => 'rw', isa => 'ValueType' ); my @common_int_params = qw/min max mandatory /; has \@common_int_params => ( is => 'ro', isa => 'Maybe[Int]' ); my @common_hash_params = qw/replace assert warn_if_match warn_unless_match warn_if warn_unless help/; has \@common_hash_params => ( is => 'ro', isa => 'Maybe[HashRef]' ); my @common_list_params = qw/choice/; has \@common_list_params => ( is => 'ro', isa => 'Maybe[ArrayRef]' ); my @common_str_params = qw/default upstream_default convert match grammar warn/; has \@common_str_params => ( is => 'ro', isa => 'Maybe[Str]' ); my @warp_accessible_params = ( @common_int_params, @common_str_params, @common_list_params, @common_hash_params ); my @allowed_warp_params = ( @warp_accessible_params, qw/level help/ ); my @backup_list = ( @allowed_warp_params, qw/migrate_from/ ); has compute_is_upstream_default => ( is => 'ro', isa => 'Bool', lazy => 1, builder => '_compute_is_upstream_default' ); sub _compute_is_upstream_default { my $self = shift; return 0 unless defined $self->compute; return $self->compute_obj->use_as_upstream_default; } has compute_is_default => ( is => 'ro', isa => 'Bool', lazy => 1, builder => '_compute_is_default' ); sub _compute_is_default { my $self = shift; return 0 unless defined $self->compute; return !$self->compute_obj->use_as_upstream_default; } has error_list => ( is => 'ro', isa => 'ArrayRef', default => sub { [] }, traits => ['Array'], handles => { add_error => 'push', clear_errors => 'clear', error_msg => [ join => "\n" ], has_error => 'count', all_errors => 'elements', is_ok => 'is_empty' } ); has warning_list => ( is => 'ro', isa => 'ArrayRef', default => sub { [] }, traits => ['Array'], handles => { add_warning => 'push', clear_warnings => 'clear', warning_msg => [ join => "\n\t" ], has_warning => 'count', all_warnings => 'elements', } ); # as some information must be backed up even though they are not # attributes, we cannot move below code in BUILD. around BUILDARGS => sub { my $orig = shift; my $class = shift; my %args = @_; my %h = map { ( $_ => $args{$_} ); } grep { defined $args{$_} } @backup_list; return $class->$orig( backup => dclone( \%h ), @_ ); }; sub BUILD { my $self = shift; $self->set_properties(); # set will use backup data # used when self is a warped slave if ( my $warp_info = $self->warp ) { $self->{warper} = Config::Model::Warper->new( warped_object => $self, %$warp_info, allowed => \@allowed_warp_params ); } $self->_init; return $self; } override 'needs_check' => sub { my $self = shift; if ($self->instance->layered) { # don't check value and don't store value in layered mode return 0; } elsif (@_) { return super(); } else { # some items like idElementReference are too complex to propagate # a change notification back to the value using them. So an error or # warning must always be rechecked. return ($self->value_type eq 'reference' or super()) ; } }; sub notify_change { my $self = shift; my %args = @_; my $check_done = $args{check_done} || 0; return if $self->instance->initial_load and not $args{really}; $change_logger->debug( "called while needs_check is ", $self->needs_check, " for ", $self->name, " with ", join( ' ', %args ) ) if $change_logger->is_debug; $self->needs_check(1) unless $check_done; { no warnings 'uninitialized'; croak "needless change with $args{new}" if defined $args{old} and defined $args{new} and $args{old} eq $args{new}; } $self->map_write_as_inplace( @args{qw/old new/} ); $self->SUPER::notify_change( %args, value_type => $self->value_type ); # notify all warped or computed objects that depends on me foreach my $s ( $self->get_depend_slave ) { $change_logger->debug( "calling notify_change on slave ", $s->name ) if $change_logger->is_debug; $s->notify_change( note => 'master triggered changed' ); } } # internal method sub set_default { my ( $self, $arg_ref ) = @_; if ( exists $arg_ref->{built_in} ) { $arg_ref->{upstream_default} = delete $arg_ref->{built_in}; warn $self->name, " warning: deprecated built_in parameter, ", "use upstream_default\n"; } if ( defined $arg_ref->{default} and defined $arg_ref->{upstream_default} ) { Config::Model::Exception::Model->throw( object => $self, error => "Cannot specify both 'upstream_default' and " . "'default' parameters", ); } foreach my $item (qw/upstream_default default/) { my $def = delete $arg_ref->{$item}; next unless defined $def; $self->transform_boolean( \$def ) if $self->value_type eq 'boolean'; # will check default value $self->check_value( value => $def ); Config::Model::Exception::Model->throw( object => $self, error => "Wrong $item value\n\t" . $self->error_msg ) if $self->has_error; $logger->debug( "Set $item value for ", $self->name, "" ); $self->{$item} = $def; } } # set up relation between objects required by the compute constructor # parameters sub _build_compute_obj { my $self = shift; $logger->debug("called"); my $c_info = $self->compute; return unless $c_info; my @compute_data; foreach ( keys %$c_info ) { push @compute_data, $_, $c_info->{$_} if defined $c_info->{$_}; } my $ret = Config::Model::ValueComputer->new( @compute_data, value_object => $self, value_type => $self->{value_type}, ); # resolve any recursive variables before registration my $v = $ret->compute_variables; $self->register_in_other_value($v); $logger->debug("done"); return $ret; } sub register_in_other_value { my $self = shift; my $var = shift; # register compute or refer_to dependency. This info may be used # by other tools foreach my $path ( values %$var ) { if ( defined $path and not ref $path ) { # is ref during test case #print "path is '$path'\n"; next if $path =~ /\$/; # next if path also contain a variable my $master = $self->grab($path); next unless $master->can('register_dependency'); $master->register_dependency($self); } } } # internal sub perform_compute { my $self = shift; $logger->debug("called"); my $result = $self->compute_obj->compute; # check if the computed result fits with the constraints of the # Value object my $ok = $self->check_fetched_value($result); if ( not $ok ) { my $error = $self->error_msg . "\n\t" . $self->compute_info; Config::Model::Exception::WrongValue->throw( object => $self, error => "computed value error:\n\t" . $error ); } $logger->debug("done"); return $ok ? $result : undef; } # internal, used to generate error messages sub compute_info { my $self = shift; $self->compute_obj->compute_info; } sub set_migrate_from { my ( $self, $arg_ref ) = @_; my $mig_ref = delete $arg_ref->{migrate_from}; if ( ref($mig_ref) eq 'HASH' ) { $self->migrate_from($mig_ref); } else { Config::Model::Exception::Model->throw( object => $self, error => "migrate_from value must be a hash ref not $mig_ref" ); } my @migrate_data; foreach (qw/formula variables replace use_eval undef_is/) { push @migrate_data, $_, $mig_ref->{$_} if defined $mig_ref->{$_}; } $self->{_migrate_from} = Config::Model::ValueComputer->new( @migrate_data, value_object => $self, value_type => $self->{value_type} ); # resolve any recursive variables before registration my $v = $self->{_migrate_from}->compute_variables; } # FIXME: should it be used only once ??? sub migrate_value { my $self = shift; return undef if $self->{migration_done}; return undef if $self->instance->initial_load; $self->{migration_done} = 1; # avoid warning when reading deprecated values my $result = $self->{_migrate_from}->compute( check => 'no' ); return undef unless defined $result; # check if the migrated result fits with the constraints of the # Value object my $ok = $self->check_value( value => $result ); #print "check result: $ok\n"; if ( not $ok ) { my $error = $self->error_msg . "\n\t" . $self->{_migrate_from}->compute_info; Config::Model::Exception::WrongValue->throw( object => $self, error => "migrated value error:\n\t" . $error ); } # old value is always undef when this method is called $self->notify_change( note => 'migrated value', new => $result ) if length($result); # skip empty value (i.e. '') $self->{data} = $result; return $ok ? $result : undef; } sub setup_enum_choice { my $self = shift; my @choice = ref $_[0] ? @{ $_[0] } : @_; $logger->debug( $self->name, " setup_enum_choice with '", join( "','", @choice ), "'" ); $self->{choice} = \@choice; # store all enum values in a hash. This way, checking # whether a value is present in the enum set is easier delete $self->{choice_hash} if defined $self->{choice_hash}; map { $self->{choice_hash}{$_} = 1; } @choice; # delete the current value if it does not fit in the new # choice map { my $lv = $self->{$_}; delete $self->{$_} if ( defined $lv and not defined $self->{choice_hash}{$lv} ); } qw/data preset/; } sub setup_match_regexp { my ( $self, $what, $ref ) = @_; my $str = $self->{$what} = delete $ref->{$what}; return unless defined $str; my $vt = $self->{value_type}; if ( $vt ne 'uniline' and $vt ne 'string' ) { Config::Model::Exception::Model->throw( object => $self, error => "Can't use $what regexp with $vt, " . "expected 'uniline' or 'string'" ); } $logger->debug( $self->name, " setup $what regexp with '$str'" ); $self->{ $what . '_regexp' } = eval { qr/$str/; }; if ($@) { Config::Model::Exception::Model->throw( object => $self, error => "Unvalid $what regexp for '$str': $@" ); } } sub check_validation_regexp { my ( $self, $what, $ref ) = @_; my $regexp_info = delete $ref->{$what}; return unless defined $regexp_info; $self->{$what} = $regexp_info; my $vt = $self->{value_type}; if ( $vt ne 'uniline' and $vt ne 'string' ) { Config::Model::Exception::Model->throw( object => $self, error => "Can't use $what regexp with $vt, " . "expected 'uniline' or 'string'" ); } if ( not ref $regexp_info and $what ne 'warn' ) { warn $self->name, ": deprecated $what style. Use a hash ref\n"; } my $h = ref $regexp_info ? $regexp_info : { $regexp_info => '' }; # just check the regexp. values are checked later in &check_value foreach my $regexp ( keys %$h ) { $logger->debug( $self->name, " hash $what regexp with '$regexp'" ); eval { qr/$regexp/; }; if ($@) { Config::Model::Exception::Model->throw( object => $self, error => "Unvalid $what regexp '$regexp': $@" ); } my $v = $h->{$regexp}; Config::Model::Exception::Model->throw( object => $self, error => "value of $what regexp '$regexp' is not a hash ref but '$v'" ) unless ref $v eq 'HASH'; } } sub setup_grammar_check { my ( $self, $ref ) = @_; my $str = $self->{grammar} = delete $ref->{grammar}; return unless defined $str; my $vt = $self->{value_type}; if ( $vt ne 'uniline' and $vt ne 'string' ) { Config::Model::Exception::Model->throw( object => $self, error => "Can't use match regexp with $vt, " . "expected 'uniline' or 'string'" ); } my @lines = split /\n/, $str; chomp @lines; if ( $lines[0] !~ /^check:/ ) { $lines[0] = 'check: ' . $lines[0] . ' /\s*\Z/ '; } my $actual_grammar = join( "\n", @lines ) . "\n"; $logger->debug( $self->name, " setup_grammar_check with '$actual_grammar'" ); eval { $self->{validation_parser} = Parse::RecDescent->new($actual_grammar); }; if ($@) { Config::Model::Exception::Model->throw( object => $self, error => "Unvalid grammar for '$str': $@" ); } } # warning : call to 'set' are not cumulative. Default value are always # restored. Lest keeping track of what was modified with 'set' is # too confusing. sub set_properties { my $self = shift; # cleanup all parameters that are handled by warp map( delete $self->{$_}, @allowed_warp_params ); # merge data passed to the constructor with data passed to set_properties my %args = ( %{ $self->{backup} }, @_ ); # these are handled by Node or Warper map { delete $args{$_} } qw/level/; my $logger = $logger; if ( $logger->is_debug ) { $logger->debug( "Leaf '" . $self->name . "' set_properties called with '", join( "','", sort keys %args ), "'" ); } if ( defined $args{value_type} and $args{value_type} eq 'reference' and not defined $self->{refer_to} and not defined $self->{computed_refer_to} ) { Config::Model::Exception::Model->throw( object => $self, error => "Missing 'refer_to' or 'computed_refer_to' " . "parameter with 'reference' value_type " ); } map { $self->{$_} = delete $args{$_} if defined $args{$_} } qw/min max mandatory replace warn replace_follow assert warn_if warn_unless write_as/; $self->set_help( \%args ); $self->set_value_type( \%args ); $self->set_default( \%args ); $self->set_convert( \%args ) if defined $args{convert}; $self->setup_match_regexp( match => \%args ) if defined $args{match}; foreach (qw/warn_if_match warn_unless_match/) { $self->check_validation_regexp( $_ => \%args ) if defined $args{$_}; } $self->setup_grammar_check( \%args ) if defined $args{grammar}; # cannot be warped $self->set_migrate_from( \%args ) if defined $args{migrate_from}; Config::Model::Exception::Model->throw( object => $self, error => "write_as is allowed only with boolean values" ) if defined $self->{write_as} and $self->{value_type} ne 'boolean'; Config::Model::Exception::Model->throw( object => $self, error => "Unexpected parameters: " . join( ' ', each %args ) ) if scalar keys %args; if ( $self->has_warped_slaves ) { my $value = $self->_fetch_no_check; $self->trigger_warp($value); } # when properties are changed, a check is required to validate new constraints $self->needs_check(1); return $self; } # simple but may be overridden sub set_help { my ( $self, $args ) = @_; return unless defined $args->{help}; $self->{help} = delete $args->{help}; } # this code is somewhat dead as warping value_type is no longer supported # but it may come back. sub set_value_type { my ( $self, $arg_ref ) = @_; my $value_type = delete $arg_ref->{value_type} || $self->value_type; Config::Model::Exception::Model->throw( object => $self, error => "Value set: undefined value_type" ) unless defined $value_type; $self->{value_type} = $value_type; if ( $value_type eq 'boolean' ) { # convert any value to boolean $self->{data} = $self->{data} ? 1 : 0 if defined $self->{data}; $self->{preset} = $self->{preset} ? 1 : 0 if defined $self->{preset}; $self->{layered} = $self->{layered} ? 1 : 0 if defined $self->{layered}; } elsif ($value_type eq 'reference' or $value_type eq 'enum' ) { my $choice = delete $arg_ref->{choice}; $self->setup_enum_choice($choice) if defined $choice; } elsif (any {$value_type eq $_} qw/string integer number uniline file dir/ ) { Config::Model::Exception::Model->throw( object => $self, error => "'choice' parameter forbidden with type " . $value_type ) if defined $arg_ref->{choice}; } else { my $msg = "Unexpected value type : '$value_type' " . "expected 'boolean', 'enum', 'uniline', 'string' or 'integer'." . "Value type can also be set up with a warp relation"; Config::Model::Exception::Model->throw( object => $self, error => $msg ) unless defined $self->{warp}; } } sub submit_to_refer_to { my $self = shift; if ( defined $self->{refer_to} ) { $self->{ref_object} = Config::Model::IdElementReference->new( refer_to => $self->{refer_to}, config_elt => $self, ); } elsif ( defined $self->{computed_refer_to} ) { $self->{ref_object} = Config::Model::IdElementReference->new( computed_refer_to => $self->{computed_refer_to}, config_elt => $self, ); # refer_to registration is done for all element that are used as # variable for complex reference (ie '- $foo' , {foo => '- bar'} ) $self->register_in_other_value( $self->{computed_refer_to}{variables} ); } else { croak "value's submit_to_refer_to: undefined refer_to or computed_refer_to"; } } sub setup_reference_choice { my $self = shift; $self->setup_enum_choice(@_); } sub reference_object { my $self = shift; return $self->{ref_object}; } sub built_in { carp "warning: built_in sub is deprecated, use upstream_default"; goto &upstream_default; } ## FIXME::what about id ?? sub name { my $self = shift; my $name = $self->{parent}->name . ' ' . $self->{element_name}; $name .= ':' . $self->{index_value} if defined $self->{index_value}; return $name; } sub get_type { return 'leaf'; } sub get_cargo_type { return 'leaf'; } sub can_store { my $self = shift; return not defined $self->compute || $self->compute_obj->allow_user_override; } sub get_default_choice { my $self = shift; return @{ $self->{backup}{choice} || [] }; } sub get_choice { my $self = shift; # just in case the reference_object has been changed if ( defined $self->{refer_to} or defined $self->{computed_refer_to} ) { $self->{ref_object}->get_choice_from_refered_to; } return @{ $self->{choice} || [] }; } sub get_help { my $self = shift; my $help = $self->{help}; return $help unless @_; my $on_value = shift; return $help->{$on_value} if defined $help and defined $on_value; return; } # construct an error message for enum types sub enum_error { my ( $self, $value ) = @_; my @error; if ( not defined $self->{choice} ) { push @error, "$self->{value_type} type has no defined choice", $self->warp_error; return @error; } my @choice = map( "'$_'", $self->get_choice ); my $var = $self->{value_type}; my $str_value = defined $value ? $value : ''; push @error, "$self->{value_type} type does not know '$value'. Expected " . join( " or ", @choice ); push @error, "Expected list is given by '" . join( "', '", @{ $self->{refered_to_path} } ) . "'" if $var eq 'reference' && defined $self->{refered_to_path}; push @error, $self->warp_error if $self->{warp}; return @error; } sub check_value { my $self = shift; croak "check_value needs a value to check" unless @_ > 1; my %args = @_; my $value = $args{value}; my $quiet = $args{quiet} || 0; my $check = $args{check} || 'yes'; my $apply_fix = $args{fix} || 0; my $mode = $args{mode} || 'backend'; my $cb = delete $args{callback}; carp "callback parameter is deprecated" if defined $cb; #croak "Cannot specify a value with fix = 1" if $apply_fix and exists $args{value} ; if ( $logger->is_debug ) { no warnings 'uninitialized'; my $v = defined $value ? $value : ''; my $loc = $self->location; my $msg = "called from " . join( ' ', caller ) . " with value '$v' mode $mode check $check on '$loc'"; $logger->debug($msg); } # need to keep track to update GUI $self->{nb_of_fixes} = 0; # reset before check my @error; my @warn; my $vt = $self->value_type ; if ( not defined $value ) { # accept with no other check } elsif ( not defined $vt ) { push @error, "Undefined value_type"; } elsif (( $vt =~ /integer/ and $value =~ /^-?\d+$/ ) or ( $vt =~ /number/ and $value =~ /^-?\d+(\.\d+)?$/ ) ) { # correct number or integer. check min max push @error, "value $value > max limit $self->{max}" if defined $self->{max} and $value > $self->{max}; push @error, "value $value < min limit $self->{min}" if defined $self->{min} and $value < $self->{min}; } elsif ( $vt =~ /integer/ and $value =~ /^-?\d+(\.\d+)?$/ ) { push @error, "Type $vt: value $value is a number " . "but not an integer"; } elsif ( $vt eq 'file' or $vt eq 'dir' ) { if (defined $value) { my $path = path($value); if ($path->exists) { my $check = 'is_'.$vt ; push @warn, "$value is not a $vt" if not path($value)->$check; } else { push @warn, "$vt $value does not exists" ; } } } elsif ( $vt eq 'reference' ) { # just in case the reference_object has been changed if ( defined $self->{refer_to} or defined $self->{computed_refer_to} ) { $self->{ref_object}->get_choice_from_refered_to; } if ( length($value) and defined $self->{choice_hash} and not defined $self->{choice_hash}{$value} ) { push @error, ( $quiet ? 'reference error' : $self->enum_error($value) ); } } elsif ( $vt eq 'enum' ) { if ( length($value) and defined $self->{choice_hash} and not defined $self->{choice_hash}{$value} ) { push @error, ( $quiet ? 'enum error' : $self->enum_error($value) ); } } elsif ( $vt eq 'boolean' ) { push @error, "error: '$value' is not boolean, i.e. not " . join ( ' or ', map { "'$_'"} $self->map_write_as(qw/0 1/)) unless $value =~ /^[01]$/; } elsif ($vt =~ /integer/ or $vt =~ /number/ ) { push @error, "Value '$value' is not of type " . $vt; } elsif ( $vt eq 'uniline' ) { push @error, '"uniline" value must not contain embedded newlines (\n)' if $value =~ /\n/; } elsif ( $vt eq 'string' ) { # accepted, no more check } else { my $choice_msg = ''; $choice_msg .= ", choice " . join( " ", $self->get_choice ) . ")" if defined $self->{choice}; my $msg = "Cannot check value_type '$vt' (value '$value'$choice_msg)"; Config::Model::Exception::Model->throw( object => $self, message => $msg ); } # a value may be mandatory and have a default value with layers if ( $self->{mandatory} and $check eq 'yes' and ( $mode =~ /backend|user/ ) and ( not defined $value or not length($value) ) and ( not defined $self->{layered} or not length($self->{layered})) ) { # check only "empty" mode. my $msg = "Undefined mandatory value."; $msg .= $self->warp_error if defined $self->{warped_attribute}{default}; push @error, $msg; } if ( defined $self->{match_regexp} and defined $value ) { push @error, "value '$value' does not match regexp " . $self->{match} unless $value =~ $self->{match_regexp}; } if ( $mode ne 'custom' ) { if ( $self->{warn_if_match} ) { my $test_sub = sub { my ( $v, $r ) = @_; $v =~ /$r/ ? 0 : 1; }; $self->run_regexp_set_on_value( \$value, $apply_fix, \@warn, 'not ', $test_sub, $self->{warn_if_match} ); } if ( $self->{warn_unless_match} ) { my $test_sub = sub { my ( $v, $r ) = @_; $v =~ /$r/ ? 1 : 0; }; $self->run_regexp_set_on_value( \$value, $apply_fix, \@warn, '', $test_sub, $self->{warn_unless_match} ); } $self->run_code_set_on_value( \$value, $apply_fix, \@error, "assert failure", $self->{assert} ) if $self->{assert}; $self->run_code_set_on_value( \$value, $apply_fix, \@warn, "warn_unless code check returned false", $self->{warn_unless} ) if $self->{warn_unless}; $self->run_code_set_on_value( \$value, $apply_fix, \@warn, "warn_if code check returned true", $self->{warn_if}, 1 ) if $self->{warn_if}; } # unconditional warn push @warn, $self->{warn} if defined $value and $self->{warn}; if ( defined $self->{validation_parser} and defined $value ) { my $prd = $self->{validation_parser}; my ( $err_msg, $warn_msg ) = ( '', '' ); my $prd_check = $prd->check( $value, 1, $self, \$err_msg, \$warn_msg ); my $prd_result = defined $prd_check ? 1 : 0; $logger->debug( "grammar check on $value returned ", defined $prd_check ? $prd_check : '' ); push @error, $err_msg || "value '$value' does not match grammar from model" unless $prd_result; push @warn, $warn_msg if $warn_msg; } $logger->debug( "check_value returns ", scalar @error, " errors and ", scalar @warn, " warnings" ); $self->clear_errors; $self->clear_warnings; $self->add_error(@error) if @error; $self->add_warning(@warn) if @warn; $args{value} = $value; # may be updated by apply_fix $logger->debug("done"); $cb->( %args, ok => not @error ) if $cb; my $ok = not @error; return wantarray ? ($ok, $value) : $ok; } sub run_code_on_value { my ( $self, $value_r, $apply_fix, $array, $label, $sub, $msg, $fix ) = @_; $logger->info( $self->location . ": run_code_on_value called (apply_fix $apply_fix)" ); my $ret = $sub->($$value_r); if ( $logger->is_debug ) { my $str = defined $ret ? $ret : ''; $logger->debug("run_code_on_value sub returned '$str'"); } unless ($ret) { $logger->debug("run_code_on_value sub returned false"); $msg =~ s/\$_/$$value_r/g if defined $$value_r; if ($msg =~ /\$std_value/) { my $std = $self->_fetch_std_no_check ; $msg =~ s/\$std_value/$std/g if defined $std; } $msg .= " (this cannot be fixed with 'cme fix' command)" unless $fix; push @$array, $msg unless $apply_fix; $self->{nb_of_fixes}++ if ( defined $fix and not $apply_fix ); $self->apply_fix( $fix, $value_r ) if ( defined $fix and $apply_fix ); } } sub run_code_set_on_value { my ( $self, $value_r, $apply_fix, $array, $msg, $w_info, $invert ) = @_; foreach my $label ( sort keys %$w_info ) { my $code = $w_info->{$label}{code}; my $msg = $w_info->{$label}{msg} || $msg; $logger->trace("eval'ed code is: '$code'"); my $fix = $w_info->{$label}{fix}; my $sub = sub { local $_ = shift; no warnings "uninitialized"; my $ret = eval($code); if ($@) { Config::Model::Exception::Model->throw( object => $self, message => "Eval of code failed : $@" ); } return $invert ^ $ret; }; $self->run_code_on_value( $value_r, $apply_fix, $array, $label, $sub, $msg, $fix ); } } sub run_regexp_set_on_value { my ( $self, $value_r, $apply_fix, $array, $msg, $test_sub, $w_info ) = @_; # no need to check default or computed values return unless defined $$value_r; foreach my $rxp ( sort keys %$w_info ) { # $_[0] is set to $$value_r when $sub is called my $sub = sub { $test_sub->( $_[0], $rxp ) }; my $msg = $w_info->{$rxp}{msg} || "value '$$value_r' should $msg" . "match regexp $rxp"; my $fix = $w_info->{$rxp}{fix}; $self->run_code_on_value( $value_r, $apply_fix, $array, 'regexp', $sub, $msg, $fix ); } } sub has_fixes { my $self = shift; return $self->{nb_of_fixes}; } sub apply_fixes { my $self = shift; if ( $logger->is_debug ) { $fix_logger->debug( "called for " . $self->location ); } my ( $old, $new ); my $i = 0; do { $old = $self->{nb_of_fixes} // 0; $self->check_value( value => $self->_fetch_no_check, fix => 1 ); $new = $self->{nb_of_fixes}; $self->check_value( value => $self->_fetch_no_check ); # if fix fails, try and check_fix call each other until this limit is found if ( $i++ > 20 ) { Config::Model::Exception::Model->throw( object => $self, error => "Too many fix loops: check code used to fix value or the check" ); } } while ( $self->{nb_of_fixes} and $old > $new ); } # internal: called by check when a fix is required sub apply_fix { my ( $self, $fix, $value_r ) = @_; local $_ = $$value_r; # used inside $fix sub ref if ( $fix_logger->is_debug ) { my $str = $fix; $str =~ s/\n/ /g; $fix_logger->info( $self->location . ": Applying fix '$str'" ); } eval($fix); if ($@) { Config::Model::Exception::Model->throw( object => $self, message => "Eval of fix $fix failed : $@" ); } no warnings "uninitialized"; if ( $_ ne $$value_r ) { $fix_logger->info( $self->location . ": fix changed value from '$$value_r' to '$_'" ); $self->_store_fix( $$value_r, $_ ); } else { $fix_logger->info( $self->location . ": fix did not change value '$$value_r'" ); } } sub _store_fix { my ( $self, $old, $new ) = @_; $self->{data} = $new; if ( $fix_logger->is_trace ) { $fix_logger->trace( "fix change: '" . ( $old // '' ) . "' -> '" . ( $new // '' ) . "'" ); } my %args = ( old => $old // $self->_fetch_std, new => $new // $self->_fetch_std, note => 'applied fix' ) ; no warnings "uninitialized"; # in case $old is the default value and $new is undef $self->notify_change( %args ) if $args{old} ne $args{new}; } # read checks should be blocking sub check { goto &check_fetched_value; } sub check_fetched_value { my $self = shift; if ( $logger->is_debug ) { no warnings 'uninitialized'; $logger->debug( "called for " . $self->location . " from " . join( ' ', caller ), " with @_" ); } my %args = @_ == 0 ? ( value => $self->{data} ) : @_ == 1 ? ( value => $_[0] ) : @_; my $value = exists $args{value} ? $args{value} : $self->{data}; my $silent = $args{silent} || 0; my $check = $args{check} || 'yes'; if ( $self->needs_check ) { $self->check_value(%args); my $err_count = $self->has_error; my $warn_count = $self->has_warning; $logger->debug("done with $err_count errors and $warn_count warnings"); $self->needs_check(0) unless $err_count or $warn_count; } else { $logger->debug("is not needed"); } # old_warn is used to avoid warning the user several times for the # same reason. We take care to clean up this hash each time this routine # is run my $old_warn = $self->{old_warning_hash} || {}; my %warn_h; if ( $self->has_warning and not $nowarning and not $silent ) { foreach my $w ( $self->all_warnings ) { $warn_h{$w} = 1; next if $old_warn->{$w}; my $str = defined $value ? "'$value'" : ''; warn "Warning in '" . $self->location_short . "' value $str: $w\n"; } } $self->{old_warning_hash} = \%warn_h; return wantarray ? $self->all_errors : $self->is_ok; } sub store { my $self = shift; my %args = @_ == 1 ? ( value => $_[0] ) : @_ == 3 ? ( 'value', @_ ) : @_; my $check = $self->_check_check( $args{check} ); my $silent = $args{silent} || 0; my $str = $args{value} // ''; $logger->debug( "called with '$str' on ", $self->composite_name ) if $logger->is_debug; # store with check skip makes sense when force loading data: bad value # is discarded, partially consistent values are stored so the user may # salvage them before next save check discard them # $self->{data} represents what written in the file my $old_value = $self->{data}; my $incoming_value = $args{value}; $self->transform_boolean( \$incoming_value ) if $self->value_type eq 'boolean'; my $value = $self->transform_value( value => $incoming_value, check => $check ); no warnings qw/uninitialized/; if ($self->instance->initial_load) { # may send more than one notification if ( $incoming_value ne $value ) { # data was transformed by model $self->notify_change(really => 1, old => $incoming_value , new => $value, note =>"initial value changed by model"); } if (defined $old_value and $old_value ne $value) { $self->notify_change(really => 1, old => $old_value , new => $value, note =>"conflicting initial values"); } if (defined $old_value and $old_value eq $value) { $self->notify_change(really => 1, note =>"removed redundant initial value"); } } if ( defined $old_value and $value eq $old_value ) { $logger->info( "skip storage of ", $self->composite_name, " unchanged value: $value" ) if $logger->is_debug; return 1; } use warnings qw/uninitialized/; $self->needs_check(1); # always when storing a value my ($ok, $fixed_value) = $self->check_stored_value( value => $value, check => $check, silent => $silent, ); $self->_store( %args, ok => $ok, value => $value, check => $check ); my $user_cb = $args{callback} ; $user_cb->(%args) if $user_cb; return $ok; } # # New subroutine "_store_value" extracted - Wed Jan 16 18:46:22 2013. # sub _store_value { my $self = shift; my $value = shift; my $notify_change = shift // 1; if ( $self->instance->layered ) { $self->{layered} = $value; } elsif ( $self->instance->preset ) { $self->notify_change( check_done => 1, old => $self->{data}, new => $value ) if $notify_change; $self->{preset} = $value; } else { no warnings 'uninitialized'; my $old = $self->{data} // $self->_fetch_std; my $new = $value // $self->_fetch_std; $self->notify_change( check_done => 1, old => $old, new => $new ) if $notify_change and ( $old ne $new ); $self->{data} = $value; # may be undef } return $value; } # this method is overriden in layered Value sub _store { my $self = shift; my %args = @_; my ( $value, $check, $silent, $notify_change, $ok ) = @args{qw/value check silent notify_change ok/}; if ( $logger->is_debug ) { my $i = $self->instance; my $msg = "value store $value, ok '$ok', check is $check"; map { $msg .= " $_" if $i->$_() } qw/layered preset/; $logger->debug($msg); } my $old_value = $self->_fetch_no_check; # FIXME: storing wrong value does not make sense # we let store the value even if wrong when check is disabled if ( $ok or $check eq 'no' ) { $self->instance->cancel_error( $self->location ); $self->_store_value( $value, $notify_change ); } else { $self->instance->add_error( $self->location ); if ($check eq 'skip') { no warnings 'uninitialized'; my $msg = "Warning: ".$self->location." skipping value $value because of the following errors:\n" . $self->error_msg . "\n\n"; if (not $silent and $msg) { # fuse UI exits when a warning is issued. No other need to advertise this option print $msg if $args{say_dont_warn}; warn $msg unless $args{say_dont_warn}; } } else { Config::Model::Exception::WrongValue->throw( object => $self, error => $self->error_msg ); } } if ( $ok and defined $value and $self->has_warped_slaves and ( not defined $old_value or $value ne $old_value ) and not( $self->instance->layered or $self->instance->preset ) ) { $self->trigger_warp($value); } $logger->debug( "_store done on ", $self->composite_name ) if $logger->is_debug; } # # New subroutine "transform_boolean" extracted - Thu Sep 19 18:58:21 2013. # sub transform_boolean { my $self = shift; my $v_ref = shift; return unless defined $$v_ref; if ( my $wa = $self->{write_as} ) { my $i = 0; map { $$v_ref = $i if ( $wa->[$i] eq $$v_ref ); $i++ } @$wa; } # convert yes no to 1 or 0 $$v_ref = 1 if ( $$v_ref =~ /^y/i or $$v_ref =~ /true/i ); $$v_ref = 0 if ( $$v_ref =~ /^n/i or $$v_ref =~ /false/i ); } # internal. return ( undef, value) # May return an undef value if actual store should be skipped sub transform_value { my $self = shift; my %args = @_ > 1 ? @_ : ( value => $_[0] ); my $value = $args{value}; my $check = $args{check} || 'yes'; my $inst = $self->instance; $self->warp if ($self->{warp} and defined $self->{warp_info} and @{ $self->{warp_info}{computed_master} } ); if ( defined $self->compute_obj and not $self->compute_obj->allow_user_override ) { my $msg = 'assignment to a computed value is forbidden unless ' . 'compute -> allow_override is set.'; Config::Model::Exception::Model->throw( object => $self, message => $msg ) if $check eq 'yes'; return; } if ( defined $self->{refer_to} or defined $self->{computed_refer_to} ) { $self->{ref_object}->get_choice_from_refered_to; } $value = $self->{convert_sub}($value) if ( defined $self->{convert_sub} and defined $value ); if ( defined $self->{replace} ) { if ( defined $self->{replace}{$value} ) { $logger->debug("store replacing value $value with $self->{replace}{$value}"); $value = $self->{replace}{$value}; } else { foreach my $k ( keys %{ $self->{replace} } ) { if ( $value =~ /^$k$/ ) { $logger->debug( "store replacing value $value (matched /$k/) with $self->{replace}{$k}"); $value = $self->{replace}{$k}; last; } } } } # using default or computed value is normally done on fetch. Except that an undefined # value cannot be stored in a mandatory value. Storing undef is used when resetting a # value to default. If a value is mandatory, we must store the default (or best equivalent) # instead if ( ( not defined $value or not length($value) ) and $self->mandatory ) { delete $self->{data}; # avoiding recycling the old stored value $value = $self->_fetch_no_check; } return $value; } sub check_stored_value { my $self = shift; my %args = @_; my ($ok, $fixed_value) = $self->check_value( %args ); my ( $value, $check, $silent ) = @args{qw/value check silent/}; $self->needs_check(0) unless $self->has_error or $self->has_warning; # old_warn is used to avoid warning the user several times for the # same reason. We take care to clean up this hash each time this routine # is run my $old_warn = $self->{old_warning_hash} || {}; my %warn_h; if ( $self->has_warning and not $nowarning and not $silent ) { foreach my $w ( $self->all_warnings ) { $warn_h{$w} = 1; next if $old_warn->{$w}; my $str = defined $value ? "'$value'" : ''; warn "Warning in '" . $self->location_short . "' value $str: $w\n"; } } $self->{old_warning_hash} = \%warn_h; return wantarray ? ($ok,$fixed_value) : $ok; } # print a hopefully helpful error message when value_type is not # defined sub _value_type_error { my $self = shift; Config::Model::Exception::Model->throw( object => $self, message => 'value_type is undefined' ) unless defined $self->{warp}; my $str = "Item " . $self->{element_name} . " is not available. " . $self->warp_error; Config::Model::Exception::User->throw( object => $self, message => $str ); } sub load_data { my $self = shift; my %args = @_ > 1 ? @_ : ( data => shift ); my $data = delete $args{data} // delete $args{value}; if ( ref $data ) { Config::Model::Exception::LoadData->throw( object => $self, message => "load_data called with non scalar arg", wrong_data => $data, ); } else { if ( $logger->is_info ) { $logger->info( "Value load_data (", $self->location, ") will store value $data" ); } $self->store(%args, value => $data); } } sub fetch_custom { my $self = shift; return $self->fetch(mode => 'custom'); } sub fetch_standard { my $self = shift; return $self->fetch(mode => 'standard'); } sub has_data { my $self = shift; return (defined $self->fetch(qw/mode custom check no silent 1/)) ? 1 : 0 ; } sub _init { my $self = shift; # trigger loop #$self->{warper} -> trigger if defined $self->{warper} ; # if ($self->{warp} and defined $self->{warp_info} # and @{$self->{warp_info}{computed_master}}); if ( defined $self->{refer_to} or defined $self->{computed_refer_to} ) { $self->submit_to_refer_to; $self->{ref_object}->get_choice_from_refered_to; } } # returns something that needs to be written to config file # unless overridden by user data sub _fetch_std { my ( $self, $check ) = @_; if ( not defined $self->{value_type} and $check eq 'yes' ) { $self->_value_type_error; } # get stored value or computed value or default value my $std_value; eval { $std_value = defined $self->{preset} ? $self->{preset} : $self->compute_is_default ? $self->perform_compute : $self->{default}; }; my $e = $@;; if ( ref($e) and $e->isa('Config::Model::Exception::User') ) { if ( $check eq 'yes' ) { $e->rethrow; } $std_value = undef; } elsif ( ref($e) ) { $e->rethrow ; } elsif ($e) { die $e; } return $std_value; } # use when std_value is needed to create error or warning message # within a check sub. Using _fetch_std leads to deep recursions sub _fetch_std_no_check { my ( $self, $check ) = @_; # get stored value or computed value or default value my $std_value; eval { $std_value = defined $self->{preset} ? $self->{preset} : $self->compute_is_default ? $self->compute_obj->compute : $self->{default}; }; if ($@) { $logger->debug("eval got error: $@"); } return $std_value; } my %old_mode = ( built_in => 'upstream_default', non_built_in => 'non_upstream_default', ); my %accept_mode = map { ( $_ => 1 ) } qw/custom standard preset default upstream_default layered non_upstream_default allow_undef user backend/; sub _fetch { my ( $self, $mode, $check ) = @_; $logger->debug( "called for " . $self->location ) if $logger->is_debug; # always call to perform submit_to_warp my $pref = $self->_fetch_std( $check ); my $data = $self->{data}; if ( defined $pref and not $self->{notified_change_for_default} and not defined $data ) { $self->{notified_change_for_default} = 1; my $info = defined $self->{preset} ? 'preset' : $self->compute_is_default ? 'computed' : 'default'; $self->notify_change( old => undef, new => $pref, note => "use $info value" ); } my $known_upstream = defined $self->{layered} ? $self->{layered} : $self->compute_is_upstream_default ? $self->perform_compute : $self->{upstream_default}; my $std = defined $pref ? $pref : $known_upstream; if ( not defined $data and defined $self->{_migrate_from} ) { $data = $self->migrate_value; } foreach my $k ( keys %old_mode ) { next unless $mode eq $k; $mode = $old_mode{$k}; carp $self->location, " warning: deprecated mode parameter: $k, ", "expected $mode\n"; } if ( $mode and not defined $accept_mode{$mode} ) { croak "fetch_no_check: expected ", join( ' or ', sort keys %accept_mode ), " parameter, not $mode"; } if ( $mode eq 'custom' ) { no warnings "uninitialized"; my $cust; $cust = $data if $data ne $pref and $data ne $self->{upstream_default} and $data ne $self->{layered}; $logger->debug( "custom mode result '$cust' for " . $self->location ) if $logger->is_debug; return $cust; } if ( $mode eq 'non_upstream_default' ) { no warnings "uninitialized"; my $nbu = defined $data && $data ne $self->{upstream_default} ? $data : defined $pref && $pref ne $self->{upstream_default} ? $pref : undef; $logger->debug( "done in non_upstream_default mode for " . $self->location ) if $logger->is_debug; return $nbu; } my $res = $mode eq 'preset' ? $self->{preset} : $mode eq 'default' ? $self->{default} : $mode eq 'standard' ? $std : $mode eq 'layered' ? $self->{layered} : $mode eq 'upstream_default' ? $self->{upstream_default} : $mode eq 'user' ? defined $data ? $data : $std : $mode eq 'allow_undef' ? defined $data ? $data : $std : $mode eq 'backend' ? defined $data ? $data : $pref : die "unexpected mode $mode "; $logger->debug( "done in '$mode' mode for " . $self->location . " -> " . ( $res // '' ) ) if $logger->is_debug; return $res; } sub fetch_no_check { my $self = shift; carp "fetch_no_check is deprecated. Use fetch (check => 'no')"; $self->fetch( check => 'no' ); } # likewise but without any warp, etc related check sub _fetch_no_check { my $self = shift; return defined $self->{data} ? $self->{data} : defined $self->{preset} ? $self->{preset} : defined $self->{compute} ? $self->perform_compute : defined $self->{_migrate_from} ? $self->migrate_value : $self->{default}; } sub fetch { my $self = shift; my %args = @_ > 1 ? @_ : ( mode => $_[0] ); my $mode = $args{mode} || 'backend'; my $silent = $args{silent} || 0; my $check = $self->_check_check( $args{check} ); if ( $logger->is_debug ) { $logger->debug( "called for " . $self->location . " check $check mode $mode" . " needs_check " . $self->needs_check ); } my $inst = $self->instance; my $value = $self->_fetch( $mode, $check ); if ( $logger->is_debug ) { $logger->debug( "_fetch returns " . ( defined $value ? $value : '' ) ); } if ( $mode and not defined $accept_mode{$mode} ) { croak "fetch: expected ", not scalar join( ' or ', sort keys %accept_mode ), " parameter, not $mode"; } if ( defined $self->{replace_follow} and defined $value ) { my $rep = $self->grab_value( step => $self->{replace_follow} . qq!:"$value"!, mode => 'loose', autoadd => 0, ); # store replaced value to trigger notify_change if ( defined $rep and $rep ne $value ) { $value = $self->_store_value($rep); } } # check and subsequent storage of fixes instruction must be done only # in user or custom mode. (because fixes are cleaned up during check and using # mode may not trigger the warnings. Hence confusion afterwards) my $ok = 1; $ok = $self->check( value => $value, silent => $silent, mode => $mode ) if $mode =~ /backend|custom|user/; $logger->debug( "$mode fetch (almost) done for " . $self->location ) if $logger->is_debug; # check validity (all modes) if ( $ok or $check eq 'no' ) { return $self->map_write_as($value); } elsif ( $check eq 'skip' ) { my $msg = $self->error_msg; my $str = $value // ''; warn "Warning: fetch [".$self->name,"] skipping value $str because of the following errors:\n$msg\n\n" if not $silent and $msg; return undef; } Config::Model::Exception::WrongValue->throw( object => $self, error => $self->error_msg ); return; } sub map_write_as { my $self = shift; my @res = map { my $do_map = (defined $_ and $self->{write_as} and $self->value_type eq 'boolean'); $do_map ? $self->{write_as}[$_] : $_; } @_ ; return wantarray ? @res : $res[0]; } # modifies in place the passed values (which are also returned) sub map_write_as_inplace { my $self = shift; map { $_ = $self->{write_as}[$_] if defined $_ and $self->{write_as} and $self->value_type eq 'boolean'; } @_; } sub user_value { return shift->{data}; } sub fetch_preset { my $self = shift; return $self->map_write_as( $self->{preset} ); } sub clear { my $self = shift; $self->store(undef); } sub clear_preset { my $self = shift; delete $self->{preset}; return defined $self->{layered} || defined $self->{data}; } sub fetch_layered { my $self = shift; return $self->map_write_as( $self->{layered} ); } sub clear_layered { my $self = shift; delete $self->{layered}; return defined $self->{preset} || defined $self->{data}; } sub get { my $self = shift; my %args = @_ > 1 ? @_ : ( path => $_[0] ); my $path = delete $args{path}; if ($path) { Config::Model::Exception::User->throw( object => $self, message => "get() called with a value with non-empty path: '$path'" ); } return $self->fetch(%args); } sub set { my $self = shift; my $path = shift; if ($path) { Config::Model::Exception::User->throw( object => $self, message => "set() called with a value with non-empty path: '$path'" ); } return $self->store(@_); } #These methods are important when this leaf value is used as a warp #master, or a variable in a compute formula. # register a dependency, This information may be used by external # tools sub register_dependency { my $self = shift; my $slave = shift; unshift @{ $self->{depend_on_me} }, $slave; # weaken only applies to the passed reference, and there's no way # to duplicate a weak ref. Only a strong ref is created. weaken( $self->{depend_on_me}[0] ); } sub get_depend_slave { my $self = shift; my @result = (); push @result, @{ $self->{depend_on_me} } if defined $self->{depend_on_me}; push @result, $self->get_warped_slaves; # needs to clean up weak ref to object that were destroyed return grep { defined $_ } @result; } __PACKAGE__->meta->make_immutable; 1; # ABSTRACT: Strongly typed configuration value __END__ =pod =encoding UTF-8 =head1 NAME Config::Model::Value - Strongly typed configuration value =head1 VERSION version 2.097 =head1 SYNOPSIS use Config::Model; # define configuration tree object my $model = Config::Model->new; $model ->create_config_class ( name => "MyClass", element => [ [qw/foo bar/] => { type => 'leaf', value_type => 'string', description => 'foobar', } , country => { type => 'leaf', value_type => 'enum', choice => [qw/France US/], description => 'big countries', } , ], ) ; my $inst = $model->instance(root_class_name => 'MyClass' ); my $root = $inst->config_root ; # put data $root->load( steps => 'foo=FOO country=US' ); print $root->report ; # foo = FOO # DESCRIPTION: foobar # # country = US # DESCRIPTION: big countries =head1 DESCRIPTION This class provides a way to specify configuration value with the following properties: =over =item * Strongly typed scalar: the value can either be an enumerated type, a boolean, a number, an integer or a string =item * default parameter: a value can have a default value specified during the construction. This default value is written in the target configuration file. (C parameter) =item * upstream default parameter: specifies a default value that is used by the application when no information is provided in the configuration file. This upstream_default value is not written in the configuration files. Only the C method returns the builtin value. This parameter was previously referred as C value. This may be used for audit purpose. (C parameter) =item * mandatory value: reading a mandatory value raises an exception if the value is not specified and has no default value. =item * dynamic change of property: A slave value can be registered to another master value so that the properties of the slave value can change according to the value of the master value. For instance, paper size value can be 'letter' for country 'US' and 'A4' for country 'France'. =item * A reference to the Id of a hash of list element. In other word, the value is an enumerated type where the possible values (choice) is defined by the existing keys of a has element somewhere in the tree. See L. =back =head1 Default values There are several kind of default values. They depend on where these values are defined (or found). From the lowest default level to the "highest": =over =item * C: The value is known in the application, but is not written in the configuration file. =item * C: The value is known by the application through another mean (e.g. an included configuration file), but is not written in the configuration file. =item * C: The value is known by the model, but not by the application. This value must be written in the configuration file. =item * C: The value is computed from other configuration elements. This value must be written in the configuration file. =item * C: The value is not known by the model or by the application. But it can be found by an automatic program and stored while the configuration L is in L =back Then there is the value entered by the user. This overrides all kind of "default" value. The L function returns the "highest" level of default value, but does not return a custom value, i.e. a value entered by the user. =head1 Constructor Value object should not be created directly. =head1 Value model declaration A leaf element must be declared with the following parameters: =over =item value_type Either C, C, C, C, C, C, C, C. Mandatory. See L. =item default Specify the default value (optional) =item upstream_default Specify a built in default value (optional). I.e a value known by the application which does not need to be written in the configuration file. =item write_as Array ref. Reserved for boolean value. Specify how to write a boolean value. Default is C<[0,1]> which may not be the most readable. C can be specified as C<['false','true']> or C<['no','yes']>. =item compute 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 contaims a number: warn_if => { warn_test => { code => 'defined $_ && /\d/;', msg => 'value $_ should not have numbers', fix => 's/\d//g;' } }, =item warn_unless Like C, but issue a warning when the given C returns false. The example below warns unless the value points to an existing directory: warn_unless => { 'dir' => { code => '-d', msg => 'missing dir', fix => "system(mkdir $_);" } } =item assert Like C. Except that returned value triggers an error when the given code returns false: assert => { test_nb => { code => 'defined $_ && /\d/;', msg => 'should not have numbers', fix => 's/\d//g;' } }, =item grammar Setup a L grammar to perform validation. If the grammar does not start with a "check" rule (i.e does not start with "check: "), the first line of the grammar 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'"} =back =head2 Value types This modules can check several value types: =over =item C Accepts values C<1> or C<0>, C or C, C or C. The value read back is always C<1> or C<0>. =item C Enum choices must be specified by the C parameter. =item C Enable positive or negative integer =item C The value can be a decimal number =item C A one line string. I.e without "\n" in it. =item C Actually, no check is performed with this type. =item C Like an C where the possible values (aka choice) is defined by another location if the configuration tree. See L. =item C A file name or path. A warning 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 ( [ on_value ] ) Returns the help strings passed to the constructor. With C parameter, returns the help string dedicated to the passed value or undef. Without parameter returns a hash ref that contains all the help strings. =head2 error_msg Returns the error messages of this object (if any) =head2 warning_msg Returns warning concerning this value. Returns a list in list context and a string in scalar context. =head2 check_value ( value ) Check the consistency of the value. C also accepts named parameters: =over 4 =item value =item quiet When non null, check 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( [ 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. =head1 Information management =head2 store( $value ) Can be called as C<< value => ..., check => yes|no|skip ), silent => 0|1 >> Store value in leaf element. C parameter can be used to skip validation check (default ies 'yes'). C cane be used to suppress warnings. Optional C is now deprecated. =head2 clear Clear the stored value. Further read returns the default value (or computed or migrated value). =head2 load_data( $value ) Load scalar data. Data is forwarded to L. Called with C or C $value )> or with the same parameters are C method. =head2 fetch_custom Returns the stored value if this value is different from a standard setting or built in setting. In other words, returns undef if the stored value is identical to the default value or the computed value or the built in value. =head2 fetch_standard Returns the standard value as defined by the configuration model. The standard value can be either a preset value, a layered value, a computed value, a default value or a built-in default value. =head2 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 returns undef for mandatory values. Normally, trying to fetch an undefined mandatory value leads to an exception. =back =head2 user_value Returns the value entered by the user. Does not use the default or computed value. Returns undef unless a value was actually stored. =head2 fetch_preset Returns the value entered in preset mode. Does not use the default or computed value. Returns undef unless a value was actually stored in preset mode. =head2 clear_preset Delete the preset value. (Even out of preset mode). Returns true if other data are still stored in the value (layered or user data). Returns false otherwise. =head2 fetch_layered Returns the value entered in layered mode. Does not use the default or computed value. Returns undef unless a value was actually stored in layered mode. =head2 clear_layered Delete the layered value. (Even out of layered mode). Returns true if other data are still stored in the value (layered or user data). Returns false otherwise. =head2 get( path => ..., mode => ... , check => ... ) Get a value from a directory like path. =head2 set( path , value ) Set a value from a directory like path. =head1 Examples =head2 Number with min and max values bounded_number => { type => 'leaf', value_type => 'number', min => 1, max => 4, }, =head2 Mandatory value mandatory_string => { type => 'leaf', value_type => 'string', mandatory => 1, }, mandatory_boolean => { type => 'leaf', value_type => 'boolean', mandatory => 1, }, =head2 Enum with help associated with each value Note that the help specification is optional. enum_with_help => { type => 'leaf', value_type => 'enum', choice => [qw/a b c/], help => { a => 'a help' } }, =head2 Migrate old obsolete enum value Legacy values C, C and C are replaced with C, C and C. with_replace => { type => 'leaf', value_type => 'enum', choice => [qw/a b c/], replace => { a1 => 'a', c1 => 'c', 'foo/.*' => 'foo', }, }, =head2 Enforce value to match a regexp An exception 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-2016 by Dominique Dumont. This is free software, licensed under: The GNU Lesser General Public License, Version 2.1, February 1999 =cut Config-Model-2.097/lib/Config/Model/AnyId.pm0000644000175000017500000012653213027007223017022 0ustar domidomi# # This file is part of Config-Model # # This software is Copyright (c) 2005-2016 by Dominique Dumont. # # This is free software, licensed under: # # The GNU Lesser General Public License, Version 2.1, February 1999 # package Config::Model::AnyId; $Config::Model::AnyId::VERSION = '2.097'; use 5.010; use Mouse; with "Config::Model::Role::NodeLoader"; use Config::Model::Exception; use Config::Model::Warper; use Carp qw/cluck croak carp/; use Log::Log4perl qw(get_logger :levels); use Storable qw/dclone/; use Mouse::Util::TypeConstraints; use Scalar::Util qw/weaken/; extends qw/Config::Model::AnyThing/; use Mouse::Util::TypeConstraints; subtype 'KeyArray' => as 'ArrayRef' ; coerce 'KeyArray' => from 'Str' => via { [$_] } ; my $logger = get_logger("Tree::Element::Id"); 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_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', } ); # work-around because 'set' does work with Mouse Number trait sub flush_fixes { $_[0]->{has_fixes} = 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' ); has content_warning_list => ( is => 'rw', isa => 'ArrayRef', default => sub { []; } ); has [qw/cargo_class max_index index_class index_type/] => ( is => 'rw', isa => 'Maybe[Str]' ); has config_model => ( is => 'ro', isa => 'Config::Model', weak_ref => 1, lazy => 1, builder => '_config_model' ); sub _config_model { my $self = shift; my $p = $self->instance->config_model; } sub config_class_name { my $self = shift; return $self->cargo->{config_class_name}; } sub BUILD { my $self = shift; croak "Missing cargo->type parameter for element " . $self->{element_name} || 'unknown' unless defined $self->cargo->{type}; if ( $self->cargo->{type} eq 'node' and not $self->cargo->{config_class_name} ) { croak "Missing cargo->config_class_name parameter for element " . $self->element_name || 'unknown'; } if ( $self->{cargo}{type} eq 'hash' or $self->{cargo}{type} eq 'list' ) { die "$self->{element_name}: using $self->{cargo}{type} will probably not work"; } $self->set_properties(); if ( defined $self->warp ) { $self->{warper} = Config::Model::Warper->new( warped_object => $self, %{ $self->warp }, allowed => \@allowed_warp_params ); } return $self; } # this method can be called by the warp mechanism to alter (warp) the # feature of the Id object. sub set_properties { my $self = shift; # mega cleanup map( delete $self->{$_}, @allowed_warp_params ); my %args = ( %{ $self->{backup} }, @_ ); # these are handled by Node or Warper map { delete $args{$_} } qw/level/; $logger->debug( $self->name, " set_properties called with @_" ); map { $self->{$_} = delete $args{$_} if defined $args{$_} } @common_params; $self->set_convert( \%args ) if defined $args{convert}; $self-> clear_warpable_check_content; map { $self-> add_warpable_check_content($_) } $self-> get_all_content_checks; map { 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->{$_}; } qw/duplicates/; Config::Model::Exception::Model->throw( object => $self, error => "Undefined index_type" ) unless defined $self->{index_type}; Config::Model::Exception::Model->throw( object => $self, error => "Unexpected index_type $self->{index_type}" ) unless ( $self->{index_type} eq 'integer' or $self->{index_type} eq 'string' ); my @current_idx = $self->_fetch_all_indexes(); if (@current_idx) { my $first_idx = shift @current_idx; my $last_idx = pop @current_idx; foreach my $idx ( ( $first_idx, $last_idx ) ) { my $ok = $self->check_idx($first_idx); next if $ok; # here a user input may trigger an exception even if fetch # or set value check is disabled. That's mostly because, # we cannot enforce more strict settings without random # deletion of data. For instance, if a hash contains 5 # items and the max_nb of items is reduced to 3. Which 2 # items should we remove ? # Since we cannot choose, we must raise an exception in # all cases. Config::Model::Exception::WrongValue->throw( error => "Error while setting id property:" . join( "\n\t", @{ $self->{idx_error_list} } ), object => $self ); } } $self->auto_create_elements; if ( defined $self->{duplicates} and defined $self->{cargo} and $self->{cargo}{type} ne 'leaf' ) { Config::Model::Exception::Model->throw( object => $self, error => "Cannot specify 'duplicates' with cargo type '$self->{cargo}{type}'", ); } my $ok_dup = 'forbid|suppress|warn|allow'; if ( defined $self->{duplicates} and $self->{duplicates} !~ /^$ok_dup$/ ) { Config::Model::Exception::Model->throw( object => $self, error => "Unexpected 'duplicates' $self->{duplicates} expected $ok_dup", ); } Config::Model::Exception::Model->throw( object => $self, error => "Unexpected parameters: " . join( ' ', keys %args ) ) if scalar keys %args; } sub create_default_with_init { my $self = shift; return unless defined $self->{default_with_init}; my $h = $self->{default_with_init}; foreach my $def_key ( keys %$h ) { my $v_obj = $self->fetch_with_id($def_key); if ( $v_obj->get_type eq 'leaf' ) { $v_obj->store( $h->{$def_key} ); } else { $v_obj->load( $h->{$def_key} ); } } } sub max { my $self = shift; carp $self->name, ": max param is deprecated, use max_index\n"; $self->max_index; } sub min { my $self = shift; carp $self->name, ": min param is deprecated, use min_index\n"; $self->min_index; } sub cargo_type { goto &get_cargo_type; } sub get_cargo_type { my $self = shift; #my @ids = $self->fetch_all_indexes ; # the returned cargo type might be different from collected type # when collected type is 'warped_node'. #return @ids ? $self->fetch_with_id($ids[0])->get_cargo_type # : $self->{cargo_type} ; return $self->{cargo}{type}; } sub get_cargo_info { my $self = shift; my $what = shift; return $self->{cargo}{$what}; } # internal, does a grab with improved error mesage sub safe_typed_grab { my $self = shift; my %args = @_; my $param = $args{param} || croak "safe_typed_grab: missing param"; my $res = eval { $self->grab( step => $self->{$param}, type => $self->get_type, check => $args{check} || 'yes', ); }; if ($@) { my $e = $@; my $msg = $e ? $e->full_message : ''; Config::Model::Exception::Model->throw( object => $self, error => "'$param' parameter: " . $msg ); } return $res; } sub get_default_keys { my $self = shift; if ( $self->{follow_keys_from} ) { my $followed = $self->safe_typed_grab( param => 'follow_keys_from' ); my @res = $followed->fetch_all_indexes; return wantarray ? @res : \@res; } my @res; push @res, @{ $self->{default_keys} } if defined $self->{default_keys}; push @res, keys %{ $self->{default_with_init} } if defined $self->{default_with_init}; return wantarray ? @res : \@res; } sub name { my $self = shift; return $self->{parent}->name . ' ' . $self->{element_name} . ' id'; } # internal. Handle model declaration arguments sub handle_args { my $self = shift; my %args = @_; my $warp_info = delete $args{warp}; map { $self->{$_} = delete $args{$_} if defined $args{$_} } qw/index_class index_type morph ordered/; $self->{backup} = dclone( \%args ); $self->set_properties(%args) if defined $self->{index_type}; if ( defined $warp_info ) { $self->{warper} = Config::Model::Warper->new( warped_object => $self, %$warp_info, allowed => \@allowed_warp_params ); } return $self; } sub apply_fixes { my $self = shift; $fix_logger->debug( $self->location . ": apply_fixes called" ); $self->deep_check( fix => 1, logger => $fix_logger ); } 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 => {}, ); sub notify_change { my $self = shift; my %args = @_; $change_logger->debug( "called for ", $self->name, " from ", join( ' ', caller ), " with ", join( ' ', %args ) ) if $change_logger->is_debug; # $idx may be undef if $self has changed, not necessarily its content my $idx = $args{index}; if ( defined $idx ) { # use $idx to trigger move from layered->preset->normal my $imode = $self->instance->get_data_mode; my $old_mode = $self->get_data_mode($idx) || 'normal'; $self->set_data_mode( $idx, $imode ) if $mode_move{$old_mode}{$imode}; } return if $self->instance->initial_load and not $args{really}; $self-> needs_content_check(1); $self->SUPER::notify_change(%args); } # 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 { my $self = shift; my @args = @_; $deep_check_logger->debug("called on ".$self->name); map { $self->check_idx(@args, index => $_); } $self->fetch_all_indexes(); $self->check_content(@args, logger => $deep_check_logger); } # check globally the list or hash, called by apply_fix or deep_check sub check_content { my $self = shift; my %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->debug( "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 instances ($nb) limit $self->{max_nb}, " if defined $self->{max_nb} and $nb > $self->{max_nb}; map { warn( "Warning in '" . $self->location_short . "': $_\n" ) } @warn unless $silent; $self->{content_warning_list} = \@warn; $self->{content_error_list} = \@error; $self-> needs_content_check(0); return scalar @error ? 0 : 1; } else { $local_logger->debug( $self->location, " has not changed, actual check skipped" ) if $logger->is_debug; my $err = $self->{content_error_list}; return scalar @$err ? 0 : 1; } } # internal function to check the validity of the index. Called when creating a new # index or when set_properties is called (init or during warp) sub check_idx { my $self = shift; my %args = @_ > 1 ? @_ : ( index => $_[0] ); my $idx = $args{index}; my $silent = $args{silent} || 0; my $check = $args{check} || 'yes'; my $apply_fix = $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 instances ($new_nb) limit $self->{max_nb}, " . "rejected id '$idx'" if defined $self->{max_nb} and $new_nb > $self->{max_nb}; if ( scalar @error ) { my @a = $self->_fetch_all_indexes; push @error, "Instance ids are '" . join( ',', @a ) . "'", $self->warp_error; } $self->{idx_error_list} = \@error; $self->{warning_hash}{$idx} = \@warn; if (@warn and not $silent and $check ne 'no') { map { warn( "Warning in '" . $self->location_short . "': $_\n" ) } @warn; } return scalar @error ? 0 : 1; } #internal sub check_follow_keys_from { my ( $self, $idx, $error ) = @_; my $followed = $self->safe_typed_grab( param => 'follow_keys_from' ); return if $followed->exists($idx); push @$error, "key '" . $self->shorten_idx($idx) . "' does not exists in '" . $followed->name . "'. Expected '" . join( "', '", $followed->fetch_all_indexes ) . "'"; } #internal sub check_allow_keys { my ( $self, $idx, $error ) = @_; my $ok = grep { $_ eq $idx } @{ $self->{allow_keys} }; push @$error, "Unexpected key '" . $self->shorten_idx($idx) . "'. Expected '" . join( "', '", @{ $self->{allow_keys} } ) . "'" unless $ok; } #internal sub check_allow_keys_matching { my ( $self, $idx, $error ) = @_; my $match = $self->{allow_keys_matching}; push @$error, "Unexpected key '" . $self->shorten_idx($idx) . "'. Key must match $match" unless $idx =~ /$match/; } #internal sub check_allow_keys_from { my ( $self, $idx, $error ) = @_; my $from = $self->safe_typed_grab( param => 'allow_keys_from' ); my $ok = grep { $_ eq $idx } $from->fetch_all_indexes; return if $ok; push @$error, "key '" . $self->shorten_idx($idx) . "' does not exists in '" . $from->name . "'. Expected '" . join( "', '", $from->fetch_all_indexes ) . "'"; } sub check_warn_if_key_match { my ( $self, $idx, $error, $warn ) = @_; my $re = $self->{warn_if_key_match}; push @$warn, "key '" . $self->shorten_idx($idx) . "' should not match $re\n" if $idx =~ /$re/; } sub check_warn_unless_key_match { my ( $self, $idx, $error, $warn ) = @_; my $re = $self->{warn_unless_key_match}; push @$warn, "key '" . $self->shorten_idx($idx) . "' should match $re\n" unless $idx =~ /$re/; } sub check_duplicates { my ( $self, $error, $warn, $apply_fix, $silent ) = @_; my $dup = $self->{duplicates}; return if $dup eq 'allow'; $logger->debug("check_duplicates called"); my %h; my @issues; my @to_delete; foreach my $i ( $self->fetch_all_indexes ) { my $v = $self->fetch_with_id( index => $i, check => 'no' )->fetch; next unless $v; $h{$v} = 0 unless defined $h{$v}; $h{$v}++; if ( $h{$v} > 1 ) { $logger->debug("got duplicates $i -> $v : $h{$v}"); push @to_delete, $i; push @issues, qq!$i:"$v"!; } } return unless @issues; if ($apply_fix) { $logger->debug("Fixing duplicates @issues, removing @to_delete"); map { $self->remove($_) } reverse @to_delete; } elsif ( $dup eq 'forbid' ) { $logger->debug("Found forbidden duplicates @issues"); push @$error, "Forbidden duplicates value @issues"; } elsif ( $dup eq 'warn' ) { $logger->debug("warning condition: found duplicate @issues"); push @$warn, "Duplicated value: @issues"; $self->add_fixes( scalar @issues); } elsif ( $dup eq 'suppress' ) { $logger->debug("suppressing duplicates @issues"); map { $self->remove($_) } reverse @to_delete; } else { die "Internal error: duplicates is $dup"; } } sub fetch_with_id { my $self = shift; my %args = @_ > 1 ? @_ : ( index => shift ); my $check = $self->_check_check( $args{check} ); my $idx = $args{index}; $logger->debug( $self->name, " called for idx $idx" ) if $logger->is_debug; $idx = $self->{convert_sub}($idx) if ( defined $self->{convert_sub} and defined $idx ); # try migration only once $self->_migrate unless $self->{migration_done}; my $ok = 1; # check index only if it's unknown $ok = $self->check_idx( index => $idx, check => $check ) unless $self->_defined($idx) or $check eq 'no'; if ( $ok or $check eq 'no' ) { $self->auto_vivify($idx) unless $self->_defined($idx); return $self->_fetch_with_id($idx); } else { Config::Model::Exception::WrongValue->throw( error => join( "\n\t", @{ $self->{idx_error_list} } ), object => $self ); } return; } sub get { my $self = shift; my %args = @_ > 1 ? @_ : ( path => $_[0] ); my $path = delete $args{path}; my $autoadd = 1; $autoadd = $args{autoadd} if defined $args{autoadd}; my $get_obj = delete $args{get_obj} || 0; $path =~ s!^/!!; my ( $item, $new_path ) = split m!/!, $path, 2; my $dcm = $args{dir_char_mockup}; # $item =~ s($dcm)(/)g if $dcm ; if ($dcm) { while (1) { my $i = index( $item, $dcm ); last if $i == -1; substr $item, $i, length($dcm), '/'; } } return unless ( $self->exists($item) or $autoadd ); $logger->debug("get: path $path, item $item"); my $obj = $self->fetch_with_id( index => $item, %args ); return $obj if ( ( $get_obj or $obj->get_type ne 'leaf' ) and not defined $new_path ); return $obj->get( path => $new_path, get_obj => $get_obj, %args ); } sub set { my $self = shift; my $path = shift; $path =~ s!^/!!; my ( $item, $new_path ) = split m!/!, $path, 2; return $self->fetch_with_id($item)->set( $new_path, @_ ); } sub copy { my ( $self, $from, $to ) = @_; my $from_obj = $self->fetch_with_id($from); my $ok = $self->check_idx($to); if ( $ok && $self->{cargo}{type} eq 'leaf' ) { $logger->trace( "AnyId: copy leaf value from " . $self->name . " $from to $to" ); $self->fetch_with_id($to)->store( $from_obj->fetch() ); } elsif ($ok) { # node object $logger->trace( "AnyId: deep copy node from " . $self->name ); my $target = $self->fetch_with_id($to); $logger->trace( "AnyId: deep copy node to " . $target->name ); $target->copy_from($from_obj); } else { Config::Model::Exception::WrongValue->throw( error => join( "\n\t", @{ $self->{idx_error_list} } ), object => $self ); } } sub fetch_all { my $self = shift; my @keys = $self->fetch_all_indexes; return map { $self->fetch_with_id($_); } @keys; } sub fetch_all_values { my $self = shift; my %args = @_ > 1 ? @_ : ( mode => shift ); my $mode = $args{mode}; my $check = $self->_check_check( $args{check} ); my @keys = $self->fetch_all_indexes; if ( $self->{cargo}{type} eq 'leaf' ) { my $ok = $check eq 'no' ? 1 : $self->check_content(); if ( $ok or $check eq 'no' ) { return grep { defined $_ } map { $self->fetch_with_id($_)->fetch( check => $check, mode => $mode ); } @keys; } else { Config::Model::Exception::WrongValue->throw( error => join( "\n\t", @{ $self->{content_error_list} } ), object => $self ); } } else { my $info = "current keys are '" . join( "', '", @keys ) . "'."; if ( $self->{cargo}{type} eq 'node' ) { $info .= "config class is " . $self->fetch_with_id( $keys[0] )->config_class_name; } Config::Model::Exception::WrongType->throw( object => $self, function => 'fetch_all_values', got_type => $self->{cargo}{type}, expected_type => 'leaf', info => $info, ); } } sub fetch_all_indexes { my $self = shift; $self->create_default; # will check itself if creation is necessary $self->_migrate; return $self->_fetch_all_indexes; } sub get_all_indexes { my $self = shift; carp "get_all_indexes is deprecated. use fetch_all_indexes"; return $self->fetch_all_indexes; } sub children { my $self = shift; return $self->fetch_all_indexes; } 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 ); } sub defined { my ( $self, $idx ) = @_; return $self->_defined($idx); } sub exists { my ( $self, $idx ) = @_; return $self->_exists($idx); } sub delete { my ( $self, $idx ) = @_; delete $self->{warning_hash}{$idx}; my $ret = $self->_delete($idx); $self->notify_change( note => "deleted entry $idx" ); return $ret; } sub clear { my ($self) = @_; $self->{warning_hash} = {}; $self->_clear; $self->clear_data_mode; $self->notify_change( note => "cleared all entries" ); } sub clear_values { my ($self) = @_; warn "clear_values deprecated"; my $ct = $self->get_cargo_type; Config::Model::Exception::User->throw( object => $self, message => "clear_values() called on non leaf cargo type: '$ct'" ) if $ct ne 'leaf'; # this will trigger a notify_change map { $self->fetch_with_id($_)->store(undef) } $self->fetch_all_indexes; $self->notify_change( note => "cleared all values" ); } sub warning_msg { my ( $self, $idx ) = @_; 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; map { push @list, @{ $self->{$_} } if $self->{$_}; } qw/idx_error_list content_error_list/; return unless @list; return wantarray ? @list : join( "\n\t", @list ); } __PACKAGE__->meta->make_immutable; 1; # ABSTRACT: Base class for hash or list element __END__ =pod =encoding UTF-8 =head1 NAME Config::Model::AnyId - Base class for hash or list element =head1 VERSION version 2.097 =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 type> (See L). =item index_type Either C or C. Mandatory for hash. =item ordered Whether to keep the order of the hash keys (default no). (a bit like L). The hash keys are ordered along their creation. The order can be modified with L, L or L. =item duplicates Specify the policy regarding duplicated values stored in the list or as hash values (valid only when cargo type is C). The policy can be C (default), C, C (which offers the possibility to apply a fix), C. Note that duplicates I: this happens outside of this object. Duplicates can be check only after when the value is read. =item cargo Hash ref specifying the cargo held by the hash of list. This has must contain: =over 8 =item type Can be C or C (default). =item config_class_name Specifies the type of configuration object held in the hash. Only valid when C C is C. =item Constructor arguments passed to the cargo object. See L when C<< cargo->type >> is C. See L when C<< cargo->type >> is C. =back =item min_index Specify the minimum value (optional, only for hash and for integer index) =item max_index Specify the maximum value (optional, only for list or for hash with integer index) =item max_nb Specify the maximum number of indexes. (hash only, optional, may also be used with string index type) =item default_keys When set, the default parameter (or set of parameters) are used as default keys hashes and created automatically when the C or C functions are used on an I hash. You can use C<< default_keys => 'foo' >>, or C<< default_keys => ['foo', 'bar'] >>. =item default_with_init To perform special set-up on children nodes you can also use default_with_init => { 'foo' => 'X=Av Y=Bv' , 'bar' => 'Y=Av Z=Cv' } When the hash contains leaves, you can also use: default_with_init => { 'def_1' => 'def_1 stuff' , 'def_2' => 'def_2 stuff' } =item migrate_keys_from Specifies that the keys of the hash are copied from another hash in the configuration tree only when the hash is read for the first time after initial load (i.e. once the configuration files are completely read). migrate_keys_from => '- another_hash' =item migrate_values_from Specifies that the values of the hash (or list) are copied from another hash (or list) in the configuration tree only when the hash (or list) is read for the first time after initial load (i.e. once the configuration files are completely read). migrate_values_from => '- another_hash_or_list' =item follow_keys_from Specifies that the keys of the hash follow the keys of another hash in the configuration tree. In other words, the 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 instance of C. Setting C to C means that C accepts two instances of C. Like other warped class, a HashId or ListId can have multiple warp masters (See L: warp => { follow => { m1 => '- macro1', m2 => '- macro2' }, rules => [ '$m1 eq "A" and $m2 eq "A2"' => { max_nb => 1}, '$m1 eq "A" and $m2 eq "B2"' => { max_nb => 2} ], } =head2 Warp and auto_create_ids or auto_create_keys When a warp is applied with C or C parameter, the auto_created items are created if they are not already present. But this warp 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( < 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 ( 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( path, value ) Set a value with a directory like path. =head2 copy ( from_index, to_index ) Deep copy an element within the hash or list. If the element contained by the hash or list is a node, all configuration information is copied from one node to another. =head2 fetch_all() Returns an array containing all elements held by the hash or list. =head2 fetch_all_values( mode => ..., check => ...) Returns an array containing all defined values held by the hash or list. (undefined values are simply discarded). This method is only valid for hash or list containing leaves. With C parameter, this method 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 =head2 fetch_all_indexes() Returns an array containing all indexes of the hash or list. Hash keys are sorted alphabetically, except for ordered hashed. =head2 children Like fetch_all_indexes. This method is polymorphic for all non-leaf objects of the configuration tree. =head2 defined ( index ) Returns true if the value held at C is defined. =head2 exists ( index ) Returns true if the value held at C exists (i.e the key exists but the value may be undefined). This method may not make sense for list element. =head2 has_data Return true if the array or hash is not empty. =head2 delete ( index ) Delete the Ced value =head2 clear() Delete all values (also delete underlying value or node objects). =head2 clear_values() Delete all values (without deleting underlying value objects). =head2 warning_msg ( [index] ) Returns warnings concerning indexes of this hash. Without parameter, returns a string containing all warnings or undef. With an index, return the warnings concerning this index or undef. =head2 has_warning Returns the current number of warning. =head2 error_msg Returns the error messages of this object (if any) =head1 AUTHOR Dominique Dumont, ddumont [AT] cpan [DOT] org =head1 SEE ALSO L, L, L, L, L, L, L, L =head1 AUTHOR Dominique Dumont =head1 COPYRIGHT AND LICENSE This software is Copyright (c) 2005-2016 by Dominique Dumont. This is free software, licensed under: The GNU Lesser General Public License, Version 2.1, February 1999 =cut Config-Model-2.097/lib/Config/Model/ListId.pm0000644000175000017500000003710513027007223017203 0ustar domidomi# # This file is part of Config-Model # # This software is Copyright (c) 2005-2016 by Dominique Dumont. # # This is free software, licensed under: # # The GNU Lesser General Public License, Version 2.1, February 1999 # package Config::Model::ListId; $Config::Model::ListId::VERSION = '2.097'; use 5.10.1; use Mouse; use Config::Model::Exception; use Log::Log4perl qw(get_logger :levels); use Carp; extends qw/Config::Model::AnyId/; with "Config::Model::Role::Grab"; my $logger = get_logger("Tree::Element::Id::List"); has data => ( is => 'rw', isa => 'ArrayRef', default => sub { []; }, traits => ['Array'], handles => { _sort_data => 'sort_in_place', _all_data => 'elements', _splice_data => 'splice', } ); # compatibility with HashId has index_type => ( is => 'ro', isa => 'Str', default => 'integer' ); has auto_create_ids => ( is => 'rw' ); sub BUILD { my $self = shift; foreach my $wrong (qw/max_nb min_index default_keys/) { Config::Model::Exception::Model->throw( object => $self, error => "Cannot use $wrong with " . $self->get_type . " element" ) if defined $self->{$wrong}; } if ( defined $self->{migrate_keys_from} ) { warn $self->name, "Using migrate_keys_from with list element is deprecated.", " Use migrate_values_from\n"; } # Supply the mandatory parameter return $self; } sub set_properties { my $self = shift; $self->SUPER::set_properties(@_); # remove unwanted items my $data = $self->{data}; return unless defined $self->{max_index}; # delete entries that no longer fit the constraints imposed by the # warp mechanism foreach my $k ( 0 .. $#{$data} ) { next unless $k > $self->{max_index}; $logger->debug( "set_properties: ", $self->name, " deleting index $k" ); delete $data->[$k]; } } sub _migrate { my $self = shift; return if $self->{migration_done}; # migration must be done *after* initial load to make sure that all data # were retrieved from the file before migration. return if $self->instance->initial_load; $self->{migration_done} = 1; if ( $self->{migrate_values_from} ) { my $followed = $self->safe_typed_grab( param => 'migrate_values_from', check => 'no' ); $logger->debug( $self->name, " migrate values from ", $followed->name ) if $logger->is_debug; my $idx = $self->fetch_size; foreach my $item ( $followed->fetch_all_indexes ) { my $data = $followed->fetch_with_id($item)->dump_as_data( check => 'no' ); $self->fetch_with_id( $idx++ )->load_data($data); } } elsif ( $self->{migrate_keys_from} ) { # FIXME: remove this deprecated stuff my $followed = $self->safe_typed_grab( param => 'migrate_keys_from', check => 'no' ); map { $self->_store( $_, undef ) unless $self->_defined($_) } $followed->fetch_all_indexes; } } sub get_type { my $self = shift; return 'list'; } # important: return the actual size (not taking into account auto-created stuff) sub fetch_size { my $self = shift; return scalar @{ $self->{data} }; } sub _fetch_all_indexes { my $self = shift; my $data = $self->{data}; return scalar @$data ? ( 0 .. $#$data ) : (); } # fetch without any check sub _fetch_with_id { my ( $self, $idx ) = @_; return $self->{data}[$idx]; } sub load { my ( $self, $string, %args ) = @_; my $check = $self->_check_check( $args{check} ); # I write too many checks. my @set; my $cmd = $string; $logger->debug( "load: ", $self->name, " called with ->$string<-" ); my $regex = qr/^( (?: " (?: \\" | [^"] )*? " ) | [^,]+ ) /x; while ( length($string) ) { #print "string: $string\n"; $string =~ s/$regex// or last; my $tmp = $1; #print "tmp: $tmp\n"; $tmp =~ s/^"|"$//g if defined $tmp; $tmp =~ s/\\"/"/g if defined $tmp; push @set, $tmp; last unless length($string); } continue { $string =~ s/^,// or last; } if ( length($string) ) { Config::Model::Exception::Load->throw( object => $self, command => $cmd, message => "unexpected load command '$cmd', left '$cmd'" ); } $self->store_set(@set); } sub store_set { my $self = shift; my @v = @_; my $r = shift; my %args = ( check => 'yes' ); if ( ref $r eq 'ARRAY' ) { @v = @$r; %args = @_; # note that $r was shifted out of @_ } $logger->debug( $self->name, " called with <".join('><',@v).'>' ); my @comments = @{ $args{comment} || [] }; my $idx = 0; foreach (@v) { if ( defined $_ ) { my $v_obj = $self->fetch_with_id( $idx++ ); $v_obj->store( %args, value => $_ ); $v_obj->annotation( shift @comments ) if @comments; } else { $self->{data}[$idx] = undef; # detruit l'objet pas bon! } } # and delete unused items my $ref = $self->{data}; while (scalar @$ref > $idx) { $self->delete($#$ref); } } # store without any check sub _store { my ( $self, $idx, $value ) = @_; return $self->{data}[$idx] = $value; } sub _defined { my ( $self, $key ) = @_; croak "argument '$key' is not numeric" unless $key =~ /^\d+$/; return defined $self->{data}[$key]; } sub _exists { my ( $self, $idx ) = @_; return exists $self->{data}[$idx]; } sub _delete { my ( $self, $idx ) = @_; return delete $self->{data}[$idx]; } sub _clear { my ($self) = @_; $self->{data} = []; } sub move { my ( $self, $from, $to, %args ) = @_; my $check = $self->_check_check( $args{check} ); my $moved = $self->fetch_with_id($from); $self->_delete($from); delete $self->{warning_hash}{$from}; my $ok = $self->check_idx($to); if ( $ok or $check eq 'no' ) { $self->_store( $to, $moved ); $moved->index_value($to); $self->notify_change( note => "moved from index $from to $to" ); my $imode = $self->instance->get_data_mode; $self->set_data_mode( $to, $imode ); } else { # restore moved item where it came from $self->_store( $from, $moved ); if ( $check ne 'skip' ) { Config::Model::Exception::WrongValue->throw( error => join( "\n\t", @{ $self->{error} } ), object => $self ); } } } # list only methods sub push { my $self = shift; $self->_assert_leaf_cargo; my $idx = $self->fetch_size; map { $self->fetch_with_id( $idx++ )->store($_); } @_; } # list only methods sub push_x { my $self = shift; my %args = @_; $self->_assert_leaf_cargo; my $check = delete $args{check} || 'yes'; my $v_arg = delete $args{values} || delete $args{value}; my @v = ref($v_arg) ? @$v_arg : ($v_arg); my $anno = delete $args{annotation}; my @a = ref($anno) ? @$anno : $anno ? ($anno) : (); croak( "push_x: unexpected parameter ", join( ' ', keys %args ) ) if %args; my $idx = $self->fetch_size; while (@v) { my $val = shift @v; my $obj = $self->fetch_with_id( $idx++ ); $obj->store($val); $obj->annotation( shift @a ) if @a; } } sub unshift { my $self = shift; $self->insert_at( 0, @_ ); } sub insert_at { my $self = shift; my $idx = shift; $self->_assert_leaf_cargo; # check if max_idx is respected $self->check_idx( $self->fetch_size + scalar @_ ); # make room at the beginning of the array $self->_splice_data( $idx, 0, (undef) x scalar @_ ); my $i = $idx; map { $self->fetch_with_id( $i++ )->store($_); } @_; $self->_reindex; } sub insert_before { my $self = shift; my $val = shift; my $test = ref($val) eq 'Regexp' ? sub { $_[0] =~ /$val/ } : sub { $_[0] eq $val }; $self->_assert_leaf_cargo; my $point = 0; foreach my $v ( $self->fetch_all_values ) { last if $test->($v); $point++; } $self->insert_at( $point, @_ ); } sub insort { my $self = shift; $self->_assert_leaf_cargo; my @insert = sort @_; my $point = 0; foreach my $v ( $self->fetch_all_values ) { while ( @insert and $insert[0] lt $v ) { $self->insert_at( $point++, shift @insert ); } $point++; } $self->push(@insert) if @insert; } sub store { my $self = shift; $self->push_x(@_); } sub _assert_leaf_cargo { my $self = shift; my $ct = $self->cargo_type; Config::Model::Exception::User->throw( object => $self, error => "Cannot call sort on list of $ct" ) unless $ct eq 'leaf'; } sub sort { my $self = shift; $self->_assert_leaf_cargo; $self->_sort_data( sub { $_[0]->fetch cmp $_[1]->fetch; } ); my $has_changed = $self->_reindex; $self->notify_change( note => "sorted" ) if $has_changed; } sub _reindex { my $self = shift; my $i = 0; my $has_changed = 0; foreach my $o ( $self->_all_data ) { next unless defined $o; $has_changed = 1 if $o->index_value != $i; $o->index_value( $i++ ); } return $has_changed; } sub swap { my $self = shift; my $ida = shift; my $idb = shift; my $obja = $self->{data}[$ida]; my $objb = $self->{data}[$idb]; # swap the index values contained in the objects my $obja_index = $obja->index_value; $obja->index_value( $objb->index_value ); $objb->index_value($obja_index); # then swap the objects $self->{data}[$ida] = $objb; $self->{data}[$idb] = $obja; $self->notify_change( note => "swapped index $ida and $idb" ); } #die "check index number after wap"; sub remove { my $self = shift; my $idx = shift; Config::Model::Exception::User->throw( object => $self, error => "Non numeric index for list: $idx" ) unless $idx =~ /^\d+$/; $self->delete_data_mode( index => $idx ); $self->notify_change(note => "removed idx $idx"); splice @{ $self->{data} }, $idx, 1; } #internal sub auto_create_elements { my $self = shift; my $auto_nb = $self->auto_create_ids; return unless defined $auto_nb; $logger->debug( $self->name, " auto-creating $auto_nb elements" ); Config::Model::Exception::Model->throw( object => $self, error => "Wrong auto_create argument for list: $auto_nb" ) unless $auto_nb =~ /^\d+$/; my $auto_p = $auto_nb - 1; # create empty slots map { $self->{data}[$_] = undef unless defined $self->{data}[$_]; } ( 0 .. $auto_p ); } # internal sub create_default { my $self = shift; return if @{ $self->{data} }; # list is empty so create empty element for default keys my $def = $self->get_default_keys; map { $self->{data}[$_] = undef } @$def; $self->create_default_with_init; } sub load_data { my $self = shift; my %args = @_ > 1 ? @_ : ( data => shift ); my $raw_data = delete $args{data}; my $check = $self->_check_check( $args{check} ); my $data = ref($raw_data) eq 'ARRAY' ? $raw_data : $args{split_reg} ? [ split $args{split_reg}, $raw_data ] : defined $raw_data ? [$raw_data] : undef; Config::Model::Exception::LoadData->throw( object => $self, message => "load_data called with non expected data. Expected array ref or scalar", wrong_data => $raw_data, ) unless defined $data; $self->clear; my $idx = 0; $logger->info( "ListId load_data (", $self->location, ") will load idx ", "0..$#$data" ); foreach my $item (@$data) { my $obj = $self->fetch_with_id( $idx++ ); $obj->load_data( %args, data => $item ); } } __PACKAGE__->meta->make_immutable; 1; # ABSTRACT: Handle list element for configuration model __END__ =pod =encoding UTF-8 =head1 NAME Config::Model::ListId - Handle list element for configuration model =head1 VERSION version 2.097 =head1 SYNOPSIS See L =head1 DESCRIPTION This class provides list elements for a L. =head1 CONSTRUCTOR ListId object should not be created directly. =head1 List model declaration See L from L. =head1 Methods =head2 get_type Returns C. =head2 fetch_size Returns the number of elements of the list. =head2 load(string, [ check => 'no' ] ) Store a set of values passed as a comma separated list of values. Values can be quoted strings. (i.e C<"a,a",b> yields C<('a,a', 'b')> list). C can be yes, no or skip =head2 store_set( ... ) Store a set of values (passed as list) If tinkering with check is required, use the following way : store_set ( \@v , check => 'skip' ); =head2 move ( from_index, to_index, [ check => 'no' ) Move an element within the list. C can be 'yes' 'no' 'skip' =head2 push( value1, [ value2 ... ] ) push some values at the end of the list. =head2 push_x ( values => [ v1','v2', ...] , ... ) Like push with extended options. Options are: =over =item check Check value validaty. Either C (default), C, C =item values Values to push (array_ref) =item value Single value to push =item annotation =back =head2 unshift( value1, [ value2 ... ] ) unshift some values at the end of the list. =head2 insert_at( idx, value1, [ value2 ... ] ) unshift some values at index idx in the list. =head2 insert_before( ( val | qr/stuff/ ) , value1, [ value2 ... ] ) unshift some values before value equal to C or before value matching C. =head2 insort( value1, [ value2 ... ] ) Insert C value on C list so that existing alphanumeric order is preserved. C yields unpexpected results when called on an unsorted list. =head2 store Equivalent to push_x. This method is provided to help write configuration parser, so the call is the same when dealing with leaf or list values. Prefer C when practical. =over 4 =item check C, C or C =item annotation list ref of annotation to store with the list values =back Example: $elt->push_x ( values => [ 'v1','v2' ] , annotation => [ 'v1 comment', 'v2 comment' ], check => 'skip' ); =head2 sort() Sort the content of the list. Can only be called on list of leaf. =head2 swap ( C , C ) Swap 2 elements within the array =head2 remove ( C ) Remove an element from the list. Equivalent to C =head2 load_data ( data => ( ref | scalar ) [, check => ... ] [ , split_reg => $re ] ) Clear and load list from data contained in the C array ref. If a scalar or a hash ref is passed, the list is cleared and the data is stored in the first element of the list. If split_reg is specified, the scalar is split to load the array. For instance $elt->load_data( data => 'foo,bar', split_reg => qr(,) ) ; loads C< [ 'foo','bar']> in C<$elt> =head1 AUTHOR Dominique Dumont, (ddumont at cpan dot org) =head1 SEE ALSO L, L, L, L, L =head1 AUTHOR Dominique Dumont =head1 COPYRIGHT AND LICENSE This software is Copyright (c) 2005-2016 by Dominique Dumont. This is free software, licensed under: The GNU Lesser General Public License, Version 2.1, February 1999 =cut Config-Model-2.097/lib/Config/Model/SimpleUI.pm0000644000175000017500000003224413027007223017501 0ustar domidomi# # This file is part of Config-Model # # This software is Copyright (c) 2005-2016 by Dominique Dumont. # # This is free software, licensed under: # # The GNU Lesser General Public License, Version 2.1, February 1999 # package Config::Model::SimpleUI; $Config::Model::SimpleUI::VERSION = '2.097'; use Carp; use 5.010; use strict; use warnings; use open qw(:std :utf8); # undeclared streams in UTF-8 use Encode qw(decode_utf8); use Regexp::Common qw/delimited/; my $syntax = ' cd cd , cd - , cd ! -> jump into node set elt=value, elt:key=value -> set a value clear elt -> clear value or list or hash delete elt:key -> delete a value from a list or hash element delete elt -> like reset, delete a value (set to undef) display elt elt:key -> display a value ls -> show elements of current node (args: filter pattern) 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) tree -> show configuration tree from current node help -> show available command desc[ription] -> show class desc of current node desc -> show desc of element from current node desc -> show effect of value (for enum) changes -> list unsaved changes 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 } grep { /^-/ } @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}; map {s/\*/.*/g;} @args ; 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; my $cmd = shift; if ($cmd) { $cmd =~ s/\s*([=:])\s*/$1/; $self->{current_node}->load($cmd); } else { say "No command given."; } return ""; }, display => sub { my $self = shift; say "Nothing to display" unless @_; return $self->{current_node}->grab_value(@_); }, ls => sub { my $self = shift; my $pattern = shift || '*'; $pattern =~ s/\*/.*/g; my $i = $self->{current_node}->instance; my @res = grep {/^$pattern$/} $self->{current_node}->get_element_name; return join( ' ', @res ); }, tree => sub { my $self = shift; my $i = $self->{current_node}->instance; my @res = $self->{current_node}->dump_tree( full_dump => 1 ); return join( ' ', @res ); }, delete => sub { my $self = shift; if ($_[0]) { my ( $elt_name, $key ) = split /\s*:\s*/, $_[0]; my $elt = $self->{current_node}->fetch_element($elt_name); if ( length($key) ) { $elt->delete($key); } else { $elt->store(undef); } } else { say "delete what ?"; } return ''; }, clear => sub { my ( $self, $elt_name ) = @_; if ($elt_name) { $self->{current_node}->fetch_element($elt_name)->clear(); } else { say "Expected element name for clear command. I.e. one of ", join(' ',$self->{current_node}->get_element_name); } return ''; }, 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 { return sort keys %run_dispatch; } sub new { my $type = shift; my %args = @_; my $self = {}; foreach my $p (qw/root title prompt/) { $self->{$p} = delete $args{$p} or croak "SimpleUI->new: Missing $p parameter"; } $self->{current_node} = $self->{root}; bless $self, $type; } sub run_loop { my $self = shift; my $user_cmd; print $self->prompt; while ( defined( $user_cmd = ) ) { chomp $user_cmd; last if $user_cmd eq 'exit' or $user_cmd eq 'quit'; my $res = $self->run($user_cmd); print $res, "\n" if defined $res; print $self->prompt; } print "\n"; my $instance = $self->{root}->instance; if ( $instance->c_count ) { my @changes = $instance->say_changes; if (@changes) { print "write back data before exit ? (Y/n)"; $user_cmd = ; $instance->write_back unless $user_cmd =~ /n/i; print "\n"; } } } sub prompt { my $self = shift; my $ret = $self->{prompt} . ':'; my $loc = $self->{current_node}->location_short; $ret .= " $loc " if $loc; return $ret . '$ '; } sub run { my ( $self, $user_cmd ) = @_; return '' unless $user_cmd =~ /\w/; my $re = $RE{delimited}{-delim=>q{'"}}; my ( $action, @args ) = ( $user_cmd =~ /((?:[^\s"']|$re)+)/g ); if ( defined $run_dispatch{$action} ) { my $res = eval { $run_dispatch{$action}->( $self, @args ); }; print $@ if $@; return $res; } else { return "Unexpected command '$action'"; } } sub list_cd_path { my $self = shift; my $c_node = $self->{current_node}; my @result; foreach my $elt_name ( $c_node->get_element_name ) { my $t = $c_node->element_type($elt_name); if ( $t eq 'list' or $t eq 'hash' ) { push @result, map { "$elt_name:$_" } $c_node->fetch_element($elt_name)->fetch_all_indexes; } else { push @result, $elt_name; } } return \@result; } 1; #ABSTRACT: Simple interface for Config::Model __END__ =pod =encoding UTF-8 =head1 NAME Config::Model::SimpleUI - Simple interface for Config::Model =head1 VERSION version 2.097 =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 [ pattern ] Show elements of current node. Can be used with a shell pattern. =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 Show configuration tree from current node. =item help Show available commands. =item desc[ription] Show class description of current node. =item desc(elt) Show description of element from current node. =item desc(value) Show effect of value (for enum) =item changes Show unsaved changes =item 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-2016 by Dominique Dumont. This is free software, licensed under: The GNU Lesser General Public License, Version 2.1, February 1999 =cut Config-Model-2.097/lib/Config/Model/TreeSearcher.pm0000644000175000017500000001410313027007223020360 0ustar domidomi# # This file is part of Config-Model # # This software is Copyright (c) 2005-2016 by Dominique Dumont. # # This is free software, licensed under: # # The GNU Lesser General Public License, Version 2.1, February 1999 # package Config::Model::TreeSearcher; $Config::Model::TreeSearcher::VERSION = '2.097'; use Mouse; use Mouse::Util::TypeConstraints; use Log::Log4perl qw(get_logger :levels); use Config::Model::Exception; use Config::Model::ObjTreeScanner; use Carp; my @search_types = qw/element value key summary description help/; enum( 'SearchType' => [ @search_types, 'all' ] ); # clean up namespace to avoid clash between MUTC keywords and # my functions # See http://www.nntp.perl.org/group/perl.moose/2010/10/msg1935.html no Mouse::Util::TypeConstraints; has 'node' => ( is => 'ro', isa => 'Config::Model::Node', weak_ref => 1, required => 1 ); has 'type' => ( is => 'ro', isa => 'SearchType' ); has '_type_hash' => ( is => 'rw', isa => 'HashRef[Bool]', builder => '_build_type_hash', lazy => 1, ); my $logger = get_logger("TreeSearcher"); sub _build_type_hash { my $self = shift; my $t = $self->type; my $def = $t eq 'all' ? 1 : 0; my %res = map { $_ => $def; } @search_types; $res{$t} = 1 unless $t eq 'all'; return \%res; } sub search { my $self = shift; my $string = shift; # string to search, can be a regexp $logger->debug( "TreeSearcher: creating scanner for " . $self->node->name ); my $reg = qr/$string/i; my @scanner_args; my $need_search = $self->_build_type_hash; push @scanner_args, leaf_cb => sub { my ( $scanner, $data_ref, $node, $element_name, $index, $leaf_object ) = @_; my $loc = $leaf_object->location; $logger->debug("TreeSearcher: scanning leaf $loc"); my $v = $leaf_object->fetch( check => 'no' ); if ( $need_search->{value} and defined $v and $v =~ $reg ) { $data_ref->($loc); } if ( $need_search->{help} ) { my $help_ref = $leaf_object->get_help; $data_ref->($loc) if grep { $_ =~ $reg; } values %$help_ref; } }; push @scanner_args, hash_element_cb => sub { my ( $scanner, $data_ref, $node, $element_name, @keys ) = @_; my $loc = $node->location; $loc .= ' ' if $loc; $loc .= $element_name; $logger->debug("TreeSearcher: scanning hash $loc"); foreach my $k (@keys) { if ( $need_search->{key} and $k =~ $reg ) { my $hloc = $node->fetch_element($element_name)->fetch_with_id($k)->location; $data_ref->($hloc); } $scanner->scan_hash( $data_ref, $node, $element_name, $k ); } }; push @scanner_args, node_content_cb => sub { my ( $scanner, $data_ref, $node, @element ) = @_; my $loc = $node->location; $logger->debug("TreeSearcher: scanning node $loc"); foreach my $e (@element) { my $store = 0; map { $store = 1 if $need_search->{$_} and $node->get_help( $_ => $e ) =~ $reg } qw/description summary/; $store = 1 if $need_search->{element} and $e =~ $reg; $data_ref->( $loc ? $loc . ' ' . $e : $e ) if $store; $scanner->scan_element( $data_ref, $node, $e ); } }; my $scan = Config::Model::ObjTreeScanner->new( @scanner_args, ); # use hash to avoid duplication of path my @loc; my $store_sub = sub { my $p = shift; return if @loc and $loc[$#loc] eq $p; $logger->debug("TreeSearcher: storing location '$p'"); push @loc, $p; }; $scan->scan_node( $store_sub, $self->node ); return @loc; } __PACKAGE__->meta->make_immutable; 1; # ABSTRACT: Search tree for match in value, description... __END__ =pod =encoding UTF-8 =head1 NAME Config::Model::TreeSearcher - Search tree for match in value, description... =head1 VERSION version 2.097 =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(keyword) Search the keyword or pattern in the tree. The search is done in a case insensitive manner. Returns a list of path pointing to the matching tree element. See L for details on the path syntax. =head1 BUGS Creating a class with just one search method may be overkill. OTOH, it may be extended later to provide iterative search. =head1 AUTHOR Dominique Dumont, (ddumont at cpan dot org) =head1 SEE ALSO L, L, L =head1 AUTHOR Dominique Dumont =head1 COPYRIGHT AND LICENSE This software is Copyright (c) 2005-2016 by Dominique Dumont. This is free software, licensed under: The GNU Lesser General Public License, Version 2.1, February 1999 =cut Config-Model-2.097/lib/Config/Model/Warper.pm0000644000175000017500000006403013027007223017250 0ustar domidomi# # This file is part of Config-Model # # This software is Copyright (c) 2005-2016 by Dominique Dumont. # # This is free software, licensed under: # # The GNU Lesser General Public License, Version 2.1, February 1999 # package Config::Model::Warper; $Config::Model::Warper::VERSION = '2.097'; use Mouse; use Log::Log4perl qw(get_logger :levels); use Data::Dumper; use Storable qw/dclone/; use Config::Model::Exception; use Carp; has 'follow' => ( is => 'ro', isa => 'HashRef[Str]', required => 1 ); has 'rules' => ( is => 'ro', isa => 'ArrayRef', required => 1 ); has 'warped_object' => ( is => 'ro', isa => 'Config::Model::AnyThing', handles => ['notify_change'], weak_ref => 1, required => 1 ); has '_values' => ( traits => ['Hash'], is => 'ro', isa => 'HashRef[HashRef | Str | Undef ]', default => sub { {} }, handles => { _set_value => 'set', _get_value => 'get', _value_keys => 'keys', }, ); sub _get_value_gist { my $self = shift; my $warper_name = shift; my $item = $self->_get_value($warper_name); return ref($item) eq 'HASH' ? join(',', each %$item) : $item; } has _computed_masters => ( is => 'rw', isa => 'HashRef', init_arg => undef ); has [qw/_warped_nodes _registered_values/] => ( is => 'rw', isa => 'HashRef', init_arg => undef, default => sub { {} }, ); has allowed => ( is => 'rw', isa => 'ArrayRef' ); has morph => ( is => 'ro', isa => 'Bool' ); my $logger = get_logger("Warper"); # create the object, check args, but don't do anything else sub BUILD { my $self = shift; $logger->debug( "Warper new: created for " . $self->name ); $self->check_warp_args; $self->register_to_all_warp_masters; $self->refresh_values_from_master; $self->do_warp; } # should be called only at startup sub register_to_all_warp_masters { my $self = shift; my $follow = $self->follow; # now, follow is only { w1 => 'warp1', w2 => 'warp2'} foreach my $warper_name ( keys %$follow ) { $self->register_to_one_warp_master($warper_name); } } sub register_to_one_warp_master { my $self = shift; my $warper_name = shift || die "register_to_one_warp_master: missing warper_name"; my $follow = $self->follow; my $warper_path = $follow->{$warper_name}; $logger->debug( "Warper register_to_one_warp_master: '", $self->name, "' follows '$warper_name'" ); # need to register also to all warped_nodes found on the path my @command = ($warper_path); my $warper; my $warped_node; my $obj = $self->warped_object; my $reg_values = $self->_registered_values; return if defined $reg_values->{$warper_name}; while (@command) { # may return undef object ( $obj, @command ) = $obj->grab( step => \@command, mode => 'step_by_step', grab_non_available => 1, ); if ( not defined $obj ) { $logger->debug("Warper register_to_one_warp_master: aborted steps. Left '@command'"); last; } my $obj_loc = $obj->location; $logger->debug("Warper register_to_one_warp_master: step to master $obj_loc"); if ( $obj->isa('Config::Model::Value') or $obj->isa('Config::Model::CheckList')) { $warper = $obj; if ( defined $warped_node ) { # keep obj ref to be able to unregister later on $self->_warped_nodes->{$warped_node}{$warper_name} = $obj; } last; } if ( $obj->isa('Config::Model::WarpedNode') ) { $logger->debug("Warper register_to_one_warp_master: register to warped_node $obj_loc"); if ( defined $warped_node ) { # keep obj ref to be able to unregister later on $self->_warped_nodes->{$warped_node}{$warper_name} = $obj; } $warped_node = $obj_loc; $obj->register( $self, $warper_name ); } } if ( defined $warper and scalar @command ) { Config::Model::Exception::Model->throw( object => $self->warped_object, error => "Some steps are left (@command) from warper path $warper_path", ); } $logger->debug( "Warper register_to_one_warp_master:", $self->name, " is warped by $warper_name => '$warper_path' location in tree is: '", defined $warper ? $warper->name : 'unknown', "'" ); return unless defined $warper; Config::Model::Exception::Model->throw( object => $self->warped_object, error => "warper $warper_name => '$warper_path' is not a leaf" ) unless $warper->isa('Config::Model::Value') or $obj->isa('Config::Model::CheckList'); # warp will register this value object in another value object # (the warper). When the warper gets a new value, it will # modify the warped object according to the data passed by the # user. my $type = $warper->register( $self, $warper_name ); $reg_values->{$warper_name} = $warper; # store current warp master value if ( $type eq 'computed' ) { $self->_computed_masters->{$warper_name} = $warper; } } sub refresh_affected_registrations { my ( $self, $warped_node_location ) = @_; my $wnref = $self->_warped_nodes; $logger->debug( "Warper refresh_affected_registrations: called on", $self->name, " from $warped_node_location'" ); #return unless defined $wnref ; # remove and unregister obj affected by this warped node my $ref = delete $wnref->{$warped_node_location}; foreach my $warper_name ( keys %$ref ) { $logger->debug( "Warper refresh_affected_registrations: ", $self->name, " unregisters from $warper_name'" ); delete $self->_registered_values->{$warper_name}; $ref->{$warper_name}->unregister( $self->name ); } $self->register_to_all_warp_masters; #map { $self->register_to_one_warp_master($_) } keys %$ref; } # should be called only at startup sub refresh_values_from_master { my $self = shift; # should get new value from warp master my $follow = $self->follow; # now, follow is only { w1 => 'warp1', w2 => 'warp2'} # should try to get values only for unregister or computed warp masters foreach my $warper_name ( keys %$follow ) { my $warper_path = $follow->{$warper_name}; $logger->debug( "Warper trigger: ", $self->name, " following $warper_name" ); # warper can itself be warped out (part of a warped out node). # not just 'not available'. my $warper = $self->warped_object->grab( step => $warper_path, mode => 'loose', ); if ( defined $warper and $warper->get_type eq 'leaf' ) { # read the warp master values, so I can warp myself just after. my $warper_value = $warper->fetch('allow_undef'); my $str = $warper_value // ''; $logger->debug( "Warper: '$warper_name' value is: '$str'" ); $self->_set_value( $warper_name => $warper_value ); } elsif ( defined $warper and $warper->get_type eq 'check_list' ) { if ($logger->is_debug) { my $warper_value = $warper->fetch(); $logger->debug( "Warper: '$warper_name' checked values are: '$warper_value'" ); } # store checked values are data structure, not as string $self->_set_value( $warper_name => scalar $warper->get_checked_list_as_hash() ); } elsif ( defined $warper ) { Config::Model::Exception::Model->throw( error => "warp error: warp 'follow' parameter " . "does not point to a leaf element", object => $self->warped_object ); } else { # consider that the warp master value is undef $self->_set_value( $warper_name, '' ); $logger->debug("Warper: '$warper_name' is not available"); } } } sub name { my $self = shift; return "Warper of " . $self->warped_object->name; } # And I'm going to warp them ... sub warp_them { my $self = shift; # retrieve current value if not provided my $value = @_ ? $_[0] : $self->fetch_no_check; foreach my $ref ( @{ $self->{warp_these_objects} } ) { my ( $warped, $warp_index ) = @$ref; next unless defined $warped; # $warped is a weak ref and may vanish # pure warp of object $logger->debug( "Warper ", $self->name, " warp_them: (value ", ( defined $value ? $value : 'undefined' ), ") warping '", $warped->name, "'" ); $warped->warp( $value, $warp_index ); } } sub check_warp_args { my $self = shift; # check that rules element are array ref and store them for # error checking my $rules_ref = $self->rules; my @rules = ref $rules_ref eq 'HASH' ? %$rules_ref : ref $rules_ref eq 'ARRAY' ? @$rules_ref : Config::Model::Exception::Model->throw( error => "warp error: warp 'rules' parameter " . "is not a ref ($rules_ref)", object => $self->warped_object ); my $allowed = $self->allowed; for ( my $r_idx = 0 ; $r_idx < $#rules ; $r_idx += 2 ) { my $key_set = $rules[$r_idx]; my @keys = ref($key_set) ? @$key_set : ($key_set); my $v = $rules[ $r_idx + 1 ]; Config::Model::Exception::Model->throw( object => $self->warped_object, error => "rules value for @keys is not a hash ref ($v)" ) unless ref($v) eq 'HASH'; foreach my $pkey ( keys %$v ) { Config::Model::Exception::Model->throw( object => $self->warped_object, error => "Warp rules error for '@keys': '$pkey' " . "parameter is not allowed, " . "expected '" . join( "' or '", @$allowed ) . "'" ) unless grep( $pkey eq $_, @$allowed ); } } } sub _dclone_key { return map { ref $_ ? [@$_] : $_ } @_; } # Internal. This method will change element properties (like level) according to the warp effect. # For instance, if a warp rule make a node no longer available in a model, its level must change to # 'hidden' sub set_parent_element_property { my ( $self, $arg_ref ) = @_; my $warped_object = $self->warped_object; my @properties = qw/level/; if ( defined $warped_object->index_value ) { $logger->debug("Warper set_parent_element_property: called on hash or list, aborted"); return; } my $parent = $warped_object->parent; my $elt_name = $warped_object->element_name; foreach my $property_name (@properties) { my $v = $arg_ref->{$property_name}; if ( defined $v ) { $logger->debug( "Warper set_parent_element_property: set '", $parent->name, " $elt_name' $property_name with $v" ); $parent->set_element_property( property => $property_name, element => $elt_name, value => $v, ); } else { # reset ensures that property is reset to known state by default $logger->debug("Warper set_parent_element_property: reset $property_name"); $parent->reset_element_property( property => $property_name, element => $elt_name, ); } } } # try to actually warp (change properties) of a warped object. sub trigger { my $self = shift; my %old_value_set = %{ $self->_values }; if (@_) { my ( $value, $warp_name ) = @_; $logger->debug( "Warper: trigger called on ", $self->name, " with value '", defined $value ? $value : '', "' name $warp_name" ); $self->_set_value( $warp_name => $value || '' ); } # read warp master values that are computed my $cm = $self->_computed_masters; foreach my $name ( keys %$cm ) { $self->_set_value( $name => $cm->{$name}->fetch ); } # check if new values are different from old values my $same = 1; foreach my $name ( $self->_value_keys ) { my $old = $old_value_set{$name}; my $new = $self->_get_value_gist($name); $same = 0 if ( $old ? 1 : 0 xor $new ? 1 : 0 ) or ( $old and $new and $new ne $old ); } if ($same) { no warnings "uninitialized"; if ( $logger->is_debug ) { $logger->debug( "Warper: warp skipped because no change in value set ", "(old: '", join( "' '", %old_value_set ), "' new: '", join( "' '", %{ $self->_values() } ), "')" ); } return; } $self->do_warp; } # undef values are changed to '' so compute_bool no longer returns # undef. It returns either 1 or 0 sub compute_bool { my $self = shift; my $expr = shift; $logger->debug("Warper compute_bool: called for '$expr'"); # my $warp_value_set = $self->_values ; $logger->debug( "Warper compute_bool: data:\n", Data::Dumper->Dump( [ $self->_values ], ['data'] ) ); # checklist: $stuff.is_set(&index) # get_value of a checklist gives { 'val1' => 1, 'val2' => 0,...} $expr =~ s/(\$\w+)\.is_set\(([&$"'\w]+)\)/$1.'->{'.$2.'}'/eg; $expr =~ s/&(\w+)/\$warped_obj->$1/g; my @init_code; my %eval_data ; foreach my $warper_name ( $self->_value_keys ) { $eval_data{$warper_name} = $self->_get_value($warper_name) ; push @init_code, "my \$$warper_name = \$eval_data{'$warper_name'} ;"; } my $perl_code = join( "\n", @init_code, $expr ); $logger->debug("Warper compute_bool: eval code '$perl_code'"); my $ret; { my $warped_obj = $self->warped_object ; no warnings "uninitialized"; $ret = eval($perl_code); } if ($@) { Config::Model::Exception::Model->throw( object => $self->warped_object, error => "Warp boolean expression failed:\n$@" . "eval'ed code is: \n$perl_code" ); } $logger->debug( "compute_bool: eval result: ", ( $ret ? 'true' : 'false' ) ); return $ret; } sub do_warp { my $self = shift; my $warp_value_set = $self->_values; my $rules = dclone( $self->rules ); my %rule_hash = @$rules; # try all boolean expression with warp_value_set to get the # correct rule my $found_rule = {}; my $found_bool = ''; # this variable may be used later in error message foreach my $bool_expr (@$rules) { next if ref($bool_expr); # it's a rule not a bool expr my $res = $self->compute_bool($bool_expr); next unless $res; $found_bool = $bool_expr; $found_rule = $rule_hash{$bool_expr} || {}; $logger->debug( "do_warp found rule for '$bool_expr':\n", Data::Dumper->Dump( [$found_rule], ['found_rule'] ) ); last; } if ( $logger->is_info ) { my @warp_str = map { defined $_ ? $_ : 'undef' } keys %$warp_value_set; $logger->info( "do_warp: warp called from '$found_bool' on '", $self->warped_object->name, "' with elements '", join( "','", @warp_str ), "', warp rule is ", ( scalar %$found_rule ? "" : 'not ' ), "found" ); } $logger->debug( "do_warp: call set_parent_element_property on '", $self->name, "' with ", Data::Dumper->Dump( [$found_rule], ['found_rule'] ) ); $self->set_parent_element_property($found_rule); $logger->debug( "do_warp: call set_properties on '", $self->warped_object->name, "' with ", Data::Dumper->Dump( [$found_rule], ['found_rule'] ) ); eval { $self->warped_object->set_properties(%$found_rule); }; if ($@) { my @warp_str = map { defined $_ ? $_ : 'undef' } keys %$warp_value_set; my $e = $@; my $msg = ref $e ? $e->as_string : $e; Config::Model::Exception::Model->throw( object => $self->warped_object, error => "Warp failed when following '" . join( "','", @warp_str ) . "' from \"$found_bool\". Check model rules:\n\t" . $msg ); } } # Usually a warp error occurs when the item is not actually available # or when a setting is wrong. Then guiding the user toward a warp # master value that has a rule attached to it is a good idea. # But sometime, the user wants to remove and item. In this case it # must be warped out by setting a warp master value that has not rule # attached. This case is indicated when $want_remove is set to 1 sub warp_error { my ($self) = @_; return '' unless defined $self->{warp}; my $follow = $self->{warp}{follow}; my @rules = @{ $self->{warp}{rules} }; # follow is either ['warp1','warp2',...] # or { warp1 => {....} , ...} or 'warp' my @warper_paths = ref($follow) eq 'ARRAY' ? @$follow : ref($follow) eq 'HASH' ? values %$follow : ($follow); my $str = "You may solve the problem by modifying " . ( @warper_paths > 1 ? "one or more of " : '' ) . "the following configuration parameters:\n"; my $expected_error = 'Config::Model::Exception::UnavailableElement'; foreach my $warper_path (@warper_paths) { my $warper_value; my $warper; # try eval { $warper = $self->get_warper_object($warper_path); $warper_value = $warper->fetch; }; my $e = $@; # catch if ( ref($e) eq $expected_error ) { $str .= "\t'$warper_path' which is unavailable\n"; next; } $warper_value = 'undef' unless defined $warper_value; my @choice = defined $warper->choice ? @{ $warper->choice } : $warper->{value_type} eq 'boolean' ? ( 0, 1 ) : (); my @try = sort grep { $_ ne $warper_value } @choice; $str .= "\t'" . $warper->location . "': Try "; my $a = $warper->{value_type} =~ /^[aeiou]/ ? 'an' : 'a'; $str .= @try ? "'" . join( "' or '", @try ) . "' instead of " : "$a $warper->{value_type} value different from "; $str .= "'$warper_value'\n"; if ( defined $warper->{compute} ) { $str .= "\n\tHowever, '" . $warper->name . "' " . $warper->compute_info . "\n"; } } $str .= "Warp parameters:\n" . Data::Dumper->Dump( [ $self->{warp} ], ['warp'] ) if $logger->is_debug; return $str; } __PACKAGE__->meta->make_immutable; # ABSTRACT: Warp tree properties 1; __END__ =pod =encoding UTF-8 =head1 NAME Config::Model::Warper - Warp tree properties =head1 VERSION version 2.097 =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-2016 by Dominique Dumont. This is free software, licensed under: The GNU Lesser General Public License, Version 2.1, February 1999 =cut Config-Model-2.097/lib/Config/Model/application.d/0000755000175000017500000000000013027007223020174 5ustar domidomiConfig-Model-2.097/lib/Config/Model/application.d/multistrap0000644000175000017500000000005313027007223022321 0ustar domidomimodel = Multistrap require_config_file = 1 Config-Model-2.097/lib/Config/Model/AnyThing.pm0000644000175000017500000003036313027007223017533 0ustar domidomi# # This file is part of Config-Model # # This software is Copyright (c) 2005-2016 by Dominique Dumont. # # This is free software, licensed under: # # The GNU Lesser General Public License, Version 2.1, February 1999 # package Config::Model::AnyThing; $Config::Model::AnyThing::VERSION = '2.097'; use Mouse; # FIXME: must cleanup warp mechanism to implement this # use MouseX::StrictConstructor; use Pod::POM; use Carp; use Log::Log4perl qw(get_logger :levels); use 5.10.1; my $logger = get_logger("Anything"); my $change_logger = get_logger("ChangeTracker"); has element_name => ( is => 'ro', isa => 'Str' ); has parent => ( is => 'ro', isa => 'Config::Model::Node', weak_ref => 1 ); has instance => ( is => 'ro', isa => 'Config::Model::Instance', weak_ref => 1, handles => [qw/show_message/] ); # needs_check defaults to 1 to trap undef mandatory values has needs_check => ( is => 'rw', isa => 'Bool', default => 1 ); # index_value can be written to when move method is called. But let's # not advertise this feature. has index_value => ( is => 'rw', isa => 'Str', trigger => sub { my $self = shift; $self->{location} = $self->_location; }, ); has container => ( is => 'ro', isa => 'Ref', required => 1, weak_ref => 1 ); has container_type => ( is => 'ro', isa => 'Str', builder => '_container_type', lazy => 1 ); sub _container_type { my $self = shift; my $p = $self->parent; return defined $p ? $p->element_type( $self->element_name ) : 'node'; # root node } has root => ( is => 'ro', isa => 'Config::Model::Node', weak_ref => 1, builder => '_root', lazy => 1 ); sub _root { my $self = shift; return $self->parent || $self; } has location => ( is => 'ro', isa => 'Str', builder => '_location', lazy => 1 ); has location_short => ( is => 'ro', isa => 'Str', builder => '_location_short', lazy => 1 ); has backend_support_annotation => ( is => 'ro', isa => 'Bool', builder => '_backend_support_annotation', lazy => 1 ); sub _backend_support_annotation { my $self = shift; # this method is overridden in Config::Model::Node return $self->parent->backend_support_annotation; }; sub notify_change { my $self = shift; my %args = @_; return if $self->instance->initial_load and not $args{really}; $change_logger->debug( "called for ", $self->name, " from ", join( ' ', caller ), " with ", join( ' ', %args ) ) if $change_logger->is_debug; # needs_save may be overridden by caller $args{needs_save} //= 1; $args{path} //= $self->location; $args{name} //= $self->element_name if $self->element_name; $args{index} //= $self->index_value if $self->index_value; # better use %args instead of @_ to forward arguments. %args eliminates duplicated keys $self->container->notify_change(%args); } sub _location { my $self = shift; my $str = ''; $str .= $self->parent->location if defined $self->parent; $str .= ' ' if $str; $str .= $self->composite_name; return $str; } sub _location_short { my $self = shift; my $str = ''; $str .= $self->parent->location_short if defined $self->parent; $str .= ' ' if $str; $str .= $self->composite_name_short; return $str; } #has composite_name => (is => 'ro', isa => 'Str' , builder => '_composite_name', lazy => 1); sub composite_name { my $self = shift; my $element = $self->element_name; $element = '' unless defined $element; my $idx = $self->index_value; return $element unless defined $idx; $idx = '"' . $idx . '"' if $idx =~ /\W/; return "$element:$idx"; } sub composite_name_short { my $self = shift; my $element = $self->element_name; $element = '' unless defined $element; my $idx = $self->shorten_idx($self->index_value); return $element unless length $idx; $idx = '"' . $idx . '"' if $idx =~ /\W/; return "$element:$idx"; } sub shorten_idx { my $self = shift; my $long_index = shift ; my @idx = split /\n/, $long_index // '' ; my $idx = shift @idx; $idx .= '[...]' if @idx; return $idx // ''; # may be undef on freebsd with perl 5.10.1 ... } ## Fixme: not yet tested sub xpath { my $self = shift; $logger->debug("xpath called on $self"); my $element = $self->element_name; $element = '' unless defined $element; my $idx = $self->index_value; my $str = ''; $str .= $self->cim_parent->parent->xpath if $self->can('cim_parent') and defined $self->cim_parent; $str .= '/' . $element . ( defined $idx ? "[\@id=$idx]" : '' ) if $element; return $str; } sub annotation { my $self = shift; my $old_note = $self->{annotation} || ''; if (@_ and not $self->instance->preset and not $self->instance->layered) { my $new = $self->{annotation} = join( "\n", grep ( defined $_, @_ ) ); $self->notify_change(note => 'updated annotation') unless $new eq $old_note; } return $self->{annotation} || ''; } sub clear_annotation { my $self = shift; $self->notify_change(note => 'deleted annotation') if $self->{annotation}; $self->{annotation} = ''; } # may be used (but not yet) to load annotation from perl data file sub load_pod_annotation { my $self = shift; my $pod = shift; my $parser = Pod::POM->new(); my $pom = $parser->parse_text($pod) || croak $parser->error(); my $sections = $pom->head1(); foreach my $s (@$sections) { next unless $s->title eq 'Annotations'; foreach my $item ( $s->over->[0]->item ) { my $path = $item->title . ''; # force string representation. Not understood why... $path =~ s/^[\s\*]+//; my $note = $item->text . ''; $note =~ s/\s+$//; $logger->debug("load_pod_annotation: '$path' -> '$note'"); $self->grab( steps => $path )->annotation($note); } } } # fallback method for object that don't implement has_data sub has_data { my $self= shift; $logger->debug("called fall-back has_data for element", $self->name) if $logger->is_debug; return 1; } sub model_searcher { my $self = shift; my %args = @_; my $model = $self->instance->config_model; return Config::Model::SearchElement->new( model => $model, node => $self, %args ); } sub searcher { carp "Config::Model::AnyThing searcher is deprecated"; goto &model_searcher; } sub dump_as_data { my $self = shift; my $dumper = Config::Model::DumpAsData->new; $dumper->dump_as_data( node => $self, @_ ); } # hum, check if the check information is valid sub _check_check { my $self = shift; my $p = shift; return 'yes' if not defined $p or $p eq '1' or $p eq 'yes'; return 'no' if $p eq '0' or $p eq 'no'; return $p if $p eq 'skip'; croak "Internal error: Unvalid check value: $p"; } sub has_fixes { my $self = shift; $logger->debug( "dummy has_fixes called on " . $self->name ); return 0; } sub has_warning { my $self = shift; $logger->debug( "dummy has_warning called on " . $self->name ); return 0; } sub warp_error { my $self = shift; return '' unless defined $self->{warper}; return $self->{warper}->warp_error; } # used by Value and AnyId sub set_convert { my ( $self, $arg_ref ) = @_; my $convert = delete $arg_ref->{convert}; # convert_sub keeps a subroutine reference $self->{convert_sub} = $convert eq 'uc' ? sub { uc(shift) } : $convert eq 'lc' ? sub { lc(shift) } : undef; Config::Model::Exception::Model->throw( object => $self, error => "Unexpected convert value: $convert, " . "expected lc or uc" ) unless defined $self->{convert_sub}; } __PACKAGE__->meta->make_immutable; 1; # ABSTRACT: Base class for configuration tree item __END__ =pod =encoding UTF-8 =head1 NAME Config::Model::AnyThing - Base class for configuration tree item =head1 VERSION version 2.097 =head1 SYNOPSIS # internal class =head1 DESCRIPTION This class must be inherited by all nodes or leaves of the configuration tree. AnyThing provides some methods and no constructor. =head1 Introspection methods =head2 element_name() Returns the element name that contain this object. =head2 index_value() For object stored in an array or hash element, returns the index (or key) containing this object. =head2 parent() Returns the node containing this object. May return undef if C is called on the root of the tree. =head2 container_type() Returns the type (e.g. C or C or C or C or C) of the element containing this object. =head2 root() Returns the root node of the configuration tree. =head2 location() Returns the node location in the configuration tree. This location conforms with the syntax defined by L method. =head2 location_short() Returns the node location in the configuration tree. This location truncates long indexes to be readable. It cannot be used by L method. =head2 composite_name Return the element name with its index (if any). I.e. returns C or C. =head2 composite_name_short Return the element name with its index (if any). Too long indexes are truncated to be readable. =head1 Annotation Annotation is a way to store miscellaneous information associated to each node. (Yeah... comments). Reading and writing annotation makes sense only if they can be read from and written to the configuration file, hence the need for the following method: =head2 backend_support_annotation Returns 1 if at least one of the backends attached to a parent node support to read and write annotations (aka comments) in the configuration file. =head2 support_annotation Returns 1 if at least one of the backends support to read and write annotations (aka comments) in the configuration file. =head2 annotation( [ note1, [ note2 , ... ] ] ) Without argument, return a string containing the object's annotation (or an empty string). With several arguments, join the arguments with "\n", store the annotations and return the resulting string. =head2 load_pod_annotation ( pod_string ) Load annotations in configuration tree from a pod document. The pod must be in the form: =over =item path Annotation text =back =head2 clear_annotation Clear the annotation of an element =head1 Information management =head2 notify_change(...) Notify the instance of semantic changes. Parameters are: =over 8 =item old old value. (optional) =item new new value (optional) =item path Location of the changed parameter starting from root node. Default to C<$self->location>. =item name element name. Default to C<$self->element_name> =item index If the changed parameter is part of a hash or an array, C contains the key or the index to get the changed parameter. =item note information about the change. Mandatory of neither old or new value are defined. =item really When set to 1, force recording of change even if in initial load phase. =item needs_save internal parameter. =back =head2 show_message( string ) Forwarded to L. =head2 model_searcher () Returns an object dedicated to search an element in the configuration model (respecting privilege level). This method returns a L object. See L for details on how to handle a search. =head2 dump_as_data ( ) Dumps the configuration data of the node and its siblings into a perl data structure. Returns a hash ref containing the data. See L for details. =head2 warp_error Returns a string describing any issue with L object. Returns '' if invoked on a tree object without warp specification. =head1 AUTHOR Dominique Dumont, (ddumont at cpan dot org) =head1 SEE ALSO L, L, L, L, L =head1 AUTHOR Dominique Dumont =head1 COPYRIGHT AND LICENSE This software is Copyright (c) 2005-2016 by Dominique Dumont. This is free software, licensed under: The GNU Lesser General Public License, Version 2.1, February 1999 =cut Config-Model-2.097/lib/Config/Model/FuseUI.pm0000644000175000017500000002613513027007223017154 0ustar domidomi# # This file is part of Config-Model # # This software is Copyright (c) 2005-2016 by Dominique Dumont. # # This is free software, licensed under: # # The GNU Lesser General Public License, Version 2.1, February 1999 # package Config::Model::FuseUI; $Config::Model::FuseUI::VERSION = '2.097'; # there's no Singleton with Mouse use Mouse; use Fuse qw(fuse_get_context); use Fcntl ':mode'; use POSIX qw(ENOENT EISDIR EINVAL); use Log::Log4perl qw(get_logger :levels); use English qw( -no_match_vars ); has model => ( is => 'rw', isa => 'Config::Model' ); has root => ( is => 'ro', isa => 'Config::Model::Node', required => 1 ); has mountpoint => ( is => 'ro', isa => 'Str', required => 1 ); my $logger = get_logger("FuseUI"); has dir_char_mockup => ( is => 'ro', isa => 'Str', default => '' ); our $fuseui; my $dir_char_mockup; sub BUILD { my $self = shift; croak( __PACKAGE__, " singleton constructed twice" ) if defined $fuseui and $fuseui ne $self; $fuseui = $self; # store singleton object in global variable $dir_char_mockup = $self->dir_char_mockup; } # nodes, list and hashes are directories sub getdir { my $name = shift; $logger->debug("FuseUI getdir called with $name"); my $obj = get_object($name); return -EINVAL() unless ( ref $obj and $obj->can('children') ); my @c = ( '..', '.', $obj->children ); map { s(/)($dir_char_mockup)g } @c; $logger->debug( "FuseUI getdir return @c , wantarray is " . ( wantarray ? 1 : 0 ) ); return ( @c, 0 ); } my %files; sub fetch_as_line { my $obj = shift; my $v = $obj->fetch( check => 'no' ); $v = '' unless defined $v; # let's append a \n so that returned files always have a line ending $v .= "\n" unless $v =~ /\n$/; return $v; } sub get_object { my $name = shift; return _get_object( $name, 0 ); } sub get_or_create_object { my $name = shift; return _get_object( $name, 1 ); } sub _get_object { my ( $name, $autoadd ) = @_; my $obj = $fuseui->root->get( path => $name, check => 'skip', get_obj => 1, autoadd => $autoadd, dir_char_mockup => $dir_char_mockup ); $logger->debug( "FuseUI _get_object on $name returns ", ( defined $obj ? $obj->name : '' ) ); return $obj; } sub getattr { my $name = shift; $logger->debug("FuseUI getattr called with $name"); my $obj = get_object($name); return -&ENOENT() unless ref $obj; my $type = $obj->get_type; # return -ENOENT() unless exists($files{$file}); my $size; if ( $type eq 'leaf' or $type eq 'check_list' ) { $size = length( fetch_as_line($obj) ); } else { my @c = $obj->children; map { s(/)($dir_char_mockup)g } @c; $size = @c; } my $mode; if ( $type eq 'leaf' or $type eq 'check_list' ) { $mode = S_IFREG | 0644; } else { $mode = S_IFDIR | 0755; } my ( $dev, $ino, $rdev, $blocks, $gid, $uid, $nlink, $blksize ) = ( 0, 0, 0, 1, $EGID, $EUID, 1, 1024 ); my ( $atime, $ctime, $mtime ); $atime = $ctime = $mtime = time; # 2 possible types of return values: #return -ENOENT(); # or any other error you care to #print(join(",",($dev,$ino,$modes,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime,$blksize,$blocks)),"\n"); my @r = ( $dev, $ino, $mode, $nlink, $uid, $gid, $rdev, $size, $atime, $mtime, $ctime, $blksize, $blocks ); $logger->trace( "FuseUI getattr returns '" . join( "','", @r ) . "'" ); return @r; } sub open { # VFS sanity check; it keeps all the necessary state, not much to do here. my $name = shift; $logger->debug("FuseUI open called on $name"); my $obj = $fuseui->root->get( path => $name, check => 'skip', get_obj => 1 ); my $type = $obj->get_type; return -ENOENT() unless defined $obj; return -EISDIR() unless ( $type eq 'leaf' or $type eq 'check_list' ); $logger->debug("FuseUI open on $name ok"); return 0; } sub read { # return an error numeric, or binary/text string. (note: 0 means EOF, "0" will # give a byte (ascii "0") to the reading program) my ( $name, $buf, $off ) = @_; $logger->debug("FuseUI read called on $name"); my $obj = get_or_create_object($name); my $type = $obj->get_type; return -ENOENT() unless defined $obj; return -EISDIR() unless ( $type eq 'leaf' or $type eq 'check_list' ); my $v = fetch_as_line($obj); if ( not defined $v ) { return -EINVAL() if $off > 0; return ''; } return -EINVAL() if $off > length($v); return 0 if $off == length($v); my $ret = substr( $v, $off, $buf ); $logger->debug("FuseUI read returns '$ret'"); return "$ret"; } sub truncate { my ( $name, $off ) = @_; $logger->debug("FuseUI truncate called on $name with length $off"); my $obj = get_or_create_object($name); my $type = $obj->get_type; return -ENOENT() unless defined $obj; return -EISDIR() unless ( $type eq 'leaf' or $type eq 'check_list' ); my $v = substr fetch_as_line($obj), 0, $off; $logger->debug( "FuseUI truncate stores '$v' of length ", length($v) ); # store the value without any check. Check will be done in write() # the second parameter will trigger a notif_change. $obj->_store_value( $v, 1 ); return 0; } sub write { my ( $name, $buf, $off ) = @_; if ( $logger->is_debug ) { my $str = $buf; $str =~ s/\n/\\n/g; $logger->debug("FuseUI write called on $name with '$str' offset $off"); } my $obj = get_or_create_object($name); my $type = $obj->get_type; return -ENOENT() unless defined $obj; return -EISDIR() unless ( $type eq 'leaf' or $type eq 'check_list' ); my $v = fetch_as_line($obj); $logger->debug("FuseUI write starts with '$v'"); substr $v, $off, length($buf), $buf; chomp $v unless ( $type eq 'leaf' and $obj->value_type eq 'string' ); $logger->debug("FuseUI write stores '$v'"); $obj->store( value => $v, check => 'skip', say_dont_warn => 1 ); return length($buf); } sub mkdir { # return an error numeric, or binary/text string. (note: 0 means EOF, "0" will # give a byte (ascii "0") to the reading program) my ( $name, $mode ) = @_; $logger->debug("FuseUI mkdir called on $name with mode $mode"); my $obj = get_or_create_object($name); return -ENOENT() unless defined $obj; my $type = $obj->container_type; return -ENOENT() unless ( $type eq 'list' or $type eq 'hash' ); return 0; } sub rmdir { # return an error numeric, or binary/text string. (note: 0 means EOF, "0" will # give a byte (ascii "0") to the reading program) my ($name) = @_; $logger->debug("FuseUI rmdir called on $name"); my $obj = get_object($name); return -ENOENT() unless defined $obj; my $type = $obj->get_type; return -ENOENT() if ( $type eq 'leaf' or $type eq 'check_list' ); my $ct = $obj->container_type; my $elt_name = $obj->element_name; my $parent = $obj->parent; if ( $ct eq 'list' or $ct eq 'hash' ) { my $idx = $obj->index_value; $logger->debug("FuseUI rmdir actually deletes $idx"); $parent->fetch_element($elt_name)->delete($idx); } # ignore deletion request for other "non deletable" elements return 0; } sub unlink { my ($name) = @_; $logger->debug("FuseUI unlink called on $name"); my $obj = get_object($name); my $type = $obj->get_type; return -ENOENT() unless defined $obj; return -EISDIR() unless ( $type eq 'leaf' or $type eq 'check_list' ); my $ct = $obj->container_type; my $elt_name = $obj->element_name; my $parent = $obj->parent; if ( $ct eq 'list' or $ct eq 'hash' ) { my $idx = $obj->index_value; $logger->debug("FuseUI unlink actually deletes $idx"); $parent->fetch_element($elt_name)->delete($name); } # ignore deletion request for other "non deletable" elements return 0; } sub statfs { return 255, 1, 1, 1, 1, 2 } my @methods = map { ( $_ => __PACKAGE__ . "::$_" ) } qw/getattr getdir open read write statfs truncate unlink mkdir rmdir/; # FIXME: flush release # maybe also: readlink mknod symlink rename link chmod chown utime sub run_loop { my ( $self, %args ) = @_; my $debug = $args{debug} || 0; Fuse::main( mountpoint => $self->mountpoint, @methods, debug => $debug || 0, threaded => 0, ); } 1; # ABSTRACT: Fuse virtual file interface for Config::Model __END__ =pod =encoding UTF-8 =head1 NAME Config::Model::FuseUI - Fuse virtual file interface for Config::Model =head1 VERSION version 2.097 =head1 SYNOPSIS # command line mkdir mydir cme fusefs popcon -fuse-dir mydir ll mydir fusermount -u mydir # programmatic use Config::Model ; use Config::Model::FuseUI ; my $model = Config::Model -> new; my $root = $model -> instance (root_class_name => "PopCon") -> config_root ; my $ui = Config::Model::FuseUI->new( root => $root, mountpoint => "mydir" ); $ui -> run_loop ; # blocking call # explore mydir in another terminal then umount mydir directory =head1 DESCRIPTION This module provides a virtual file system interface for you configuration data. Each possible parameter of your configuration file is mapped to a file. =head1 Example $ cme fusefs popcon -fuse-dir fused Mounting config on fused in background. Use command 'fusermount -u fused' to unmount $ ll fused total 4 -rw-r--r-- 1 domi domi 1 Dec 8 19:27 DAY -rw-r--r-- 1 domi domi 0 Dec 8 19:27 HTTP_PROXY -rw-r--r-- 1 domi domi 0 Dec 8 19:27 MAILFROM -rw-r--r-- 1 domi domi 0 Dec 8 19:27 MAILTO -rw-r--r-- 1 domi domi 32 Dec 8 19:27 MY_HOSTID -rw-r--r-- 1 domi domi 3 Dec 8 19:27 PARTICIPATE -rw-r--r-- 1 domi domi 0 Dec 8 19:27 SUBMITURLS -rw-r--r-- 1 domi domi 3 Dec 8 19:27 USEHTTP $ fusermount -u fuse_dir =head1 BUGS =over =item * For some configuration, mapping each parameter to a file may lead to a high number of files. =item * The content of a file is when writing a wrong value. I.e. the files is empty and the old value is lost. =back =head1 constructor =head1 new (...) parameters are: =over =item model Config::Model object =item root Root of the configuration tree (C object ) =item mountpoint =back =head1 Methods =head2 run_loop( fork_in_loop => 1|0, debug => 1|0) Mount the file system either in the current process or fork a new process before mounting the file system. In the former case, the call is blocking. In the latter case, the call returns after forking a process that performs the mount. Debug parameter is passed to Fuse system to get traces from Fuse. =head2 fuse_mount Mount the fuse file system. This method blocks until the file system is unmounted (with C command) =head1 SEE ALSO L, L, L =head1 AUTHOR Dominique Dumont =head1 COPYRIGHT AND LICENSE This software is Copyright (c) 2005-2016 by Dominique Dumont. This is free software, licensed under: The GNU Lesser General Public License, Version 2.1, February 1999 =cut Config-Model-2.097/lib/Config/Model/Utils/0000755000175000017500000000000013027007223016547 5ustar domidomiConfig-Model-2.097/lib/Config/Model/Utils/GenClassPod.pm0000644000175000017500000000424413027007223021253 0ustar domidomi# # This file is part of Config-Model # # This software is Copyright (c) 2005-2016 by Dominique Dumont. # # This is free software, licensed under: # # The GNU Lesser General Public License, Version 2.1, February 1999 # package Config::Model::Utils::GenClassPod; $Config::Model::Utils::GenClassPod::VERSION = '2.097'; # ABSTRACT: generate pod documentation from configuration models use strict; use warnings; use 5.010; use parent qw(Exporter); our @EXPORT = qw(gen_class_pod); use lib qw/lib/; use Path::Tiny ; use Config::Model ; # to generate doc sub gen_class_pod { my $cm = Config::Model -> new(model_dir => "lib/Config/Model/models") ; my %done; my @models = @_ ? @_ : map { /model\s*=\s*([\w:-]+)/; $1; } grep { /^\s*model/; } map { $_->lines; } map { $_->children; } path ("lib/Config/Model/")->children(qr/\.d$/); foreach my $model (@models) { # %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.097 =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-2016 by Dominique Dumont. This is free software, licensed under: The GNU Lesser General Public License, Version 2.1, February 1999 =cut Config-Model-2.097/lib/Config/Model/DumpAsData.pm0000644000175000017500000002615513027007223020001 0ustar domidomi# # This file is part of Config-Model # # This software is Copyright (c) 2005-2016 by Dominique Dumont. # # This is free software, licensed under: # # The GNU Lesser General Public License, Version 2.1, February 1999 # package Config::Model::DumpAsData; $Config::Model::DumpAsData::VERSION = '2.097'; use Carp; use strict; use warnings; use 5.10.1; use Config::Model::Exception; use Config::Model::ObjTreeScanner; sub new { bless {}, shift; } sub dump_as_data { my $self = shift; my %args = @_; my $dump_node = delete $args{node} || croak "dump_as_data: missing 'node' parameter"; my $fetch_mode = delete $args{mode} ; my $skip_aw = delete $args{skip_auto_write} || ''; my $auto_v = delete $args{auto_vivify} || 0; my $ordered_hash_as_list = delete $args{ordered_hash_as_list}; $ordered_hash_as_list = 1 unless defined $ordered_hash_as_list; # mode and full_dump params are both accepted my $full = delete $args{full_dump} // 1; $fetch_mode //= 'non_upstream_default' if $full; $fetch_mode //= 'custom'; my $std_cb = sub { my ( $scanner, $data_r, $obj, $element, $index, $value_obj ) = @_; $$data_r = $value_obj->fetch(mode => $fetch_mode); }; my $check_list_element_cb = sub { my ( $scanner, $data_r, $node, $element_name, @check_items ) = @_; my $a_ref = $node->fetch_element($element_name)->get_checked_list; # don't store empty checklist $$data_r = $a_ref if @$a_ref; }; my $hash_element_cb = sub { my ( $scanner, $data_ref, $node, $element_name, @keys ) = @_; # resume exploration but pass a ref on $data_ref hash element # instead of data_ref my %h; my @res; foreach my $k (@keys) { my $v; $scanner->scan_hash( \$v, $node, $element_name, $k ); # don't create the key if $v is undef $h{$k} = $v if defined $v; push @res , $k, $v if defined $v; } ; my $ordered_hash = $node->fetch_element($element_name)->ordered; if ( $ordered_hash and $ordered_hash_as_list ) { $$data_ref = \@res if @res; } else { $h{'__'.$element_name.'_order'} = \@keys if $ordered_hash and @keys; $$data_ref = \%h if scalar %h; } }; my $list_element_cb = sub { my ( $scanner, $data_ref, $node, $element_name, @idx ) = @_; # resume exploration but pass a ref on $data_ref hash element # instead of data_ref my @a; foreach my $i (@idx) { my $v; $scanner->scan_hash( \$v, $node, $element_name, $i ); push @a, $v if defined $v; } $$data_ref = \@a if scalar @a; }; my $node_content_cb = sub { my ( $scanner, $data_ref, $node, @element ) = @_; my %h; foreach my $e (@element) { my $v; $scanner->scan_element( \$v, $node, $e ); $h{$e} = $v if defined $v; } $$data_ref = \%h if scalar %h; }; my $node_element_cb = sub { my ( $scanner, $data_ref, $node, $element_name, $key, $next ) = @_; return if $skip_aw and $next->is_auto_write_for_type($skip_aw); $scanner->scan_node( $data_ref, $next ); }; my @scan_args = ( check => delete $args{check} || 'yes', fallback => 'all', auto_vivify => $auto_v, list_element_cb => $list_element_cb, check_list_element_cb => $check_list_element_cb, hash_element_cb => $hash_element_cb, leaf_cb => $std_cb, node_element_cb => $node_element_cb, node_content_cb => $node_content_cb, ); my @left = keys %args; croak "DumpAsData: unknown parameter:@left" if @left; # perform the scan my $view_scanner = Config::Model::ObjTreeScanner->new(@scan_args); my $obj_type = $dump_node->get_type; my $result; my $p = $dump_node->parent; my $e = $dump_node->element_name; my $i = $dump_node->index_value; # defined only for hash and list if ( $obj_type =~ /node/ ) { $view_scanner->scan_node( \$result, $dump_node ); } elsif ( defined $i ) { $view_scanner->scan_hash( \$result, $p, $e, $i ); } elsif ($obj_type eq 'list' or $obj_type eq 'hash' or $obj_type eq 'leaf' or $obj_type eq 'check_list' ) { $view_scanner->scan_element( \$result, $p, $e ); } else { croak "dump_as_data: unexpected type: $obj_type"; } return $result; } sub dump_annotations_as_pod { my $self = shift; my %args = @_; my $dump_node = delete $args{node} || croak "dump_annotations_as_pod: missing 'node' parameter"; my $annotation_to_pod = sub { my $obj = shift; my $path = shift || $obj->location; my $a = $obj->annotation; if ($a) { chomp $a; return "=item $path\n\n$a\n\n"; } else { return ''; } }; my $std_cb = sub { my ( $scanner, $data_r, $obj, $element, $index, $value_obj ) = @_; $$data_r .= $annotation_to_pod->($value_obj); }; my $hash_element_cb = sub { my ( $scanner, $data_ref, $node, $element_name, @keys ) = @_; my $h = $node->fetch_element($element_name); my $h_path = $h->location . ':'; foreach (@keys) { $$data_ref .= $annotation_to_pod->( $h->fetch_with_id($_), $h_path . $_ ); $scanner->scan_hash( $data_ref, $node, $element_name, $_ ); } }; my $node_content_cb = sub { my ( $scanner, $data_ref, $node, @element ) = @_; my $node_path = $node->location; $node_path .= ' ' if $node_path; foreach (@element) { $$data_ref .= $annotation_to_pod->( $node->fetch_element( name => $_, check => 'no' ), $node_path . $_ ); $scanner->scan_element( $data_ref, $node, $_ ); } }; my @scan_args = ( check => delete $args{check} || 'yes', fallback => 'all', leaf_cb => $std_cb, node_content_cb => $node_content_cb, hash_element_cb => $hash_element_cb, list_element_cb => $hash_element_cb, ); my @left = keys %args; croak "dump_annotations_as_pod: unknown parameter:@left" if @left; # perform the scan my $view_scanner = Config::Model::ObjTreeScanner->new(@scan_args); my $obj_type = $dump_node->get_type; my $result = ''; my $a = $dump_node->annotation; my $l = $dump_node->location; $result .= "=item $l\n\n$a\n\n" if $a; if ( $obj_type =~ /node/ ) { $view_scanner->scan_node( \$result, $dump_node ); } else { croak "dump_annotations_as_pod: unexpected type: $obj_type"; } return '' unless $result; return "=head1 Annotations\n\n=over\n\n" . $result . "=back\n\n"; } 1; # ABSTRACT: Dump configuration content as a perl data structure __END__ =pod =encoding UTF-8 =head1 NAME Config::Model::DumpAsData - Dump configuration content as a perl data structure =head1 VERSION version 2.097 =head1 SYNOPSIS use Config::Model ; use Data::Dumper ; # define configuration tree object my $model = Config::Model->new ; $model ->create_config_class ( name => "MyClass", element => [ [qw/foo bar/] => { type => 'leaf', value_type => 'string' }, baz => { type => 'hash', index_type => 'string' , cargo => { type => 'leaf', value_type => 'string', }, }, ], ) ; my $inst = $model->instance(root_class_name => 'MyClass' ); my $root = $inst->config_root ; # put some data in config tree the hard way $root->fetch_element('foo')->store('yada') ; $root->fetch_element('bar')->store('bla bla') ; $root->fetch_element('baz')->fetch_with_id('en')->store('hello') ; # put more data the easy way my $steps = 'baz:fr=bonjour baz:hr="dobar dan"'; $root->load( steps => $steps ) ; print Dumper($root->dump_as_data); # $VAR1 = { # 'bar' => 'bla bla', # 'baz' => { # 'en' => 'hello', # 'fr' => 'bonjour', # 'hr' => 'dobar dan' # }, # 'foo' => 'yada' # }; =head1 DESCRIPTION This module is used directly by L to dump the content of a configuration tree in perl data structure. The perl data structure is a hash of hash. Only L content is stored in an array ref. Note that undefined values are skipped for list element. I.e. if a list element contains C<('a',undef,'b')>, the data structure then contains C<'a','b'>. =head1 CONSTRUCTOR =head2 new ( ) No parameter. The constructor should be used only by L. =head1 Methods =head2 dump_as_data(...) Return a perl data structure Parameters are: =over =item node Reference to a L object. Mandatory =item full_dump Also dump default values in the data structure. Useful if the dumped configuration data is used by the application. (default is yes) Note that C parameter is also accepted and overrides C parameter. See L for details on C. =item skip_auto_write Skip node that have a C capability in their model. See L. This option must be used when using DumpAsData: to write back configuration data. When a configuration model contains several backends (one at the tree root and others in tree nodes), setting this option ensure that the "root" configuration file does not contain data duplicated in configuration file of others tree nodes. =item auto_vivify Scan and create data for nodes elements even if no actual data was stored in them. This may be useful to trap missing mandatory values. =item ordered_hash_as_list By default, ordered hash (i.e. the order of the keys are important) are dumped as Perl list. This is the faster way to dump such hashed while keeping the key order. But it's the less readable way. When this parameter is 1 (default), the ordered hash is dumped as a list: my_hash => [ A => 'foo', B => 'bar', C => 'baz' ] When this parameter is set as 0, the ordered hash is dumped with a special key that specifies the order of keys. E.g.: my_hash => { __my_hash_order => [ 'A', 'B', 'C' ] , B => 'bar', A => 'foo', C => 'baz' } =back =head1 Methods =head2 dump_annotations_as_pod(...) Return a string formatted in pod (See L) with the annotations. Parameters are: =over =item node Reference to a L object. Mandatory =item check_list Yes, no or skip =back =head1 AUTHOR Dominique Dumont, (ddumont at cpan dot org) =head1 SEE ALSO L,L,L =head1 AUTHOR Dominique Dumont =head1 COPYRIGHT AND LICENSE This software is Copyright (c) 2005-2016 by Dominique Dumont. This is free software, licensed under: The GNU Lesser General Public License, Version 2.1, February 1999 =cut Config-Model-2.097/lib/Config/Model/Dumper.pm0000644000175000017500000002603413027007223017246 0ustar domidomi# # This file is part of Config-Model # # This software is Copyright (c) 2005-2016 by Dominique Dumont. # # This is free software, licensed under: # # The GNU Lesser General Public License, Version 2.1, February 1999 # package Config::Model::Dumper; $Config::Model::Dumper::VERSION = '2.097'; use Carp; use strict; use warnings; use Config::Model::Exception; use Config::Model::ObjTreeScanner; sub new { bless {}, shift; } sub quote { _quote( qr/[\s"#*]/, @_ ); } sub id_quote { _quote( qr/[\s"*<>.=#]/, @_ ); } sub _quote { my ( $re, @res ) = @_; foreach (@res) { if ( defined $_ and ( /$re/ or $_ eq '' ) ) { s/"/\\"/g; # escape present quotes $_ = '"' . $_ . '"'; # add my quotes } } return wantarray ? @res : $res[0]; } sub note_quote { my @res = @_; foreach (@res) { if ( defined $_ and $_ and (/(\s|"|\*)/) ) { s/"/\\"/g; # escape present quotes $_ = '"' . $_ . '"'; # add my quotes } } return wantarray ? @res : $res[0]; } sub dump_tree { my $self = shift; my %args = @_; my $full = delete $args{full_dump} || 0; my $skip_aw = delete $args{skip_auto_write} || ''; my $auto_v = delete $args{auto_vivify} || 0; my $mode = delete $args{mode} || ''; if ( $mode and $mode !~ /full|preset|custom/ ) { croak "dump_tree: unexpected 'mode' value: $mode"; } my $check = delete $args{check} || 'yes'; if ( $check !~ /yes|no|skip/ ) { croak "dump_tree: unexpected 'check' value: $check"; } # mode parameter is slightly different from fetch's mode my $fetch_mode = $full ? '' : $mode eq 'full' ? '' : $mode ? $mode : 'custom'; my $node = delete $args{node} || croak "dump_tree: missing 'node' parameter"; my $compute_pad = sub { my $depth = 0; my $obj = shift; while ( defined $obj->parent ) { $depth++; $obj = $obj->parent; } return ' ' x $depth; }; my $leaf_cb = sub { my ( $scanner, $data_r, $node, $element, $index, $value_obj ) = @_; # get value or only customized value my $value = quote( $value_obj->fetch( mode => $fetch_mode, check => $check ) ); $index = id_quote($index); my $pad = $compute_pad->($node); my $name = defined $index ? "$element:$index" : $element; # add annotation for obj contained in hash or list my $note = note_quote( $value_obj->annotation ); $$data_r .= "\n" . $pad . $name if defined $value or $note; if (defined $value) { $value =~ s/\\n/\\\\n/g; $$data_r .= '=' . $value; } $$data_r .= '#' . $note if $note; }; my $check_list_cb = sub { my ( $scanner, $data_r, $node, $element, $index, $value_obj ) = @_; # get value or only customized value my $value = $value_obj->fetch( mode => $fetch_mode, check => $check ); my $qvalue = quote($value); $index = id_quote($index); my $pad = $compute_pad->($node); my $name = defined $index ? "$element:$index" : $element; # add annotation for obj contained in hash or list my $note = note_quote( $value_obj->annotation ); $$data_r .= "\n" . $pad . $name if $value or $note; $$data_r .= '=' . $qvalue if $value; $$data_r .= '#' . $note if $note; }; my $list_element_cb = sub { my ( $scanner, $data_r, $node, $element, @keys ) = @_; my $pad = $compute_pad->($node); my $list_obj = $node->fetch_element($element); # add annotation for list element my $list_note = note_quote( $list_obj->annotation ); $$data_r .= "\n$pad$element#$list_note" if $list_note; if ( $list_obj->cargo_type eq 'node' ) { foreach my $k (@keys) { $scanner->scan_list( $data_r, $node, $element, $k ); } } else { # write value comments foreach my $idx ( $list_obj->fetch_all_indexes ) { my $note = $list_obj->fetch_with_id($idx)->annotation; $$data_r .= "\n$pad$element:$idx#" . note_quote($note) if $note; } # skip undef values my @val = id_quote( grep ( defined $_, $list_obj->fetch_all_values( mode => $fetch_mode, check => $check ) ) ); $$data_r .= "\n$pad$element:=" . join( ',', @val ) if @val; } }; my $hash_element_cb = sub { my ( $scanner, $data_r, $node, $element, @keys ) = @_; my $pad = $compute_pad->($node); my $hash_obj = $node->fetch_element($element); # add annotation for list or hash element my $note = note_quote( $hash_obj->annotation ); $$data_r .= "\n$pad$element#$note" if $note; # resume exploration map { $scanner->scan_hash( $data_r, $node, $element, $_ ); } @keys; }; # called for nodes contained in nodes (not root). # This node can be held by a plain element or a hash element or a list element my $node_element_cb = sub { my ( $scanner, $data_r, $node, $element, $key, $contained_node ) = @_; my $type = $node->element_type($element); return if $skip_aw and $contained_node->is_auto_write_for_type($skip_aw); my $pad = $compute_pad->($node); my $elt = $node->fetch_element($element); # load string can feature only one comment per element_type # ie foo#comment foo:bar#comment foo:bar=val#comment are fine # but foo#comment:bar if not valid -> foo#commaent foo:bar my $head = "\n$pad$element"; my $node_note = note_quote( $contained_node->annotation ); if ( $type eq 'list' or $type eq 'hash' ) { $head .= ':' . id_quote($key); $head .= '#' . $node_note if $node_note; my $sub_data = ''; $scanner->scan_node( \$sub_data, $contained_node ); $$data_r .= $head . $sub_data . ' -'; } else { $head .= '#' . $node_note if $node_note; my $sub_data = ''; $scanner->scan_node( \$sub_data, $contained_node ); # skip simple nodes that do not bring data $$data_r .= $head . $sub_data . ' -' if $sub_data; } }; my @scan_args = ( fallback => 'all', auto_vivify => $auto_v, list_element_cb => $list_element_cb, hash_element_cb => $hash_element_cb, leaf_cb => $leaf_cb, node_element_cb => $node_element_cb, check_list_element_cb => $check_list_cb, check => $check, ); my @left = keys %args; croak "Dumper: unknown parameter:@left" if @left; # perform the scan my $view_scanner = Config::Model::ObjTreeScanner->new(@scan_args); my $ret = ''; my $root_note = note_quote( $node->annotation ); $ret .= "\n#$root_note" if $root_note; $view_scanner->scan_node( \$ret, $node ); substr( $ret, 0, 1, '' ); # remove leading \n $ret .= ' -' if $ret; return $ret . "\n"; } 1; # ABSTRACT: Serialize data of config tree __END__ =pod =encoding UTF-8 =head1 NAME Config::Model::Dumper - Serialize data of config tree =head1 VERSION version 2.097 =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. The other mode is C mode where all all data, including default values, are dumped. The serialized string can be used by L to store the data back into a configuration tree. Note that undefined values are skipped for list element. I.e. if a list element contains C<('a',undef,'b')>, the dump 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 ( full | preset | custom ) C dumps all configuration data including default values. C dumps only value entered in preset mode. By default, the dump contains only data modified by the user (i.e. C data that differ from default or preset values). =item node Reference to the L object that is dumped. All nodes and leaves attached to this node are also dumped. =item skip_auto_write ( ) Skip node that have a write capability matching C in their model. See L. 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-2016 by Dominique Dumont. This is free software, licensed under: The GNU Lesser General Public License, Version 2.1, February 1999 =cut Config-Model-2.097/lib/Config/Model/Exception.pm0000644000175000017500000003376513027007223017761 0ustar domidomi# # This file is part of Config-Model # # This software is Copyright (c) 2005-2016 by Dominique Dumont. # # This is free software, licensed under: # # The GNU Lesser General Public License, Version 2.1, February 1999 # package Config::Model::Exception; $Config::Model::Exception::VERSION = '2.097'; use warnings; use strict; use Data::Dumper; use Mouse; use 5.10.1; use Carp; @Carp::CARP_NOT=qw/Config::Model::Exception Config::Model::Exception::Any/; our $trace = 0; use Carp qw/longmess shortmess croak/; use overload '""' => \&full_msg_and_trace, 'bool' => \&is_error; has description => ( is => 'ro', isa => 'Str', lazy_build => 1 ); sub _build_description { my $self = shift; return $self->_desc; } sub _desc { 'config error' } has object => ( is => 'rw', isa => 'Ref') ; has info => (is => 'rw', isa =>'Str', default => ''); has message => (is => 'rw', isa =>'Str', default => ''); has error => (is => 'rw', isa =>'Str', default => ''); has trace => (is => 'rw', isa =>'Str', default => ''); # without this overload, a test like if ($@) invokes '""' overload sub is_error { return ref ($_[0])} sub Trace { $trace = shift; } sub error_or_msg { my $self = shift; return $self->error || $self->message; } sub throw { my $class = shift; my $self = $class->new(@_); # 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; $Config::Model::Exception::Any::VERSION = '2.097'; use Mouse; extends 'Config::Model::Exception'; package Config::Model::Exception::ModelDeclaration; $Config::Model::Exception::ModelDeclaration::VERSION = '2.097'; use Mouse; extends 'Config::Model::Exception::Fatal'; sub _desc {'configuration model declaration error' } package Config::Model::Exception::User ; $Config::Model::Exception::User::VERSION = '2.097'; use Mouse; extends 'Config::Model::Exception::Any'; sub _desc {'user error' } ## old classes below package Config::Model::Exception::Syntax; $Config::Model::Exception::Syntax::VERSION = '2.097'; use Mouse; extends 'Config::Model::Exception::Any'; sub _desc { 'syntax error' } has [qw/parsed_file parsed_line/] => (is => 'rw', isa => 'Str'); sub full_message { my $self = shift; my $fn = $self->parsed_file || '?'; my $line = $self->parsed_line || '?'; my $msg = "File $fn line $line "; $msg .= "has a " . $self->description; $msg .= ":\n\t" . $self->error_or_msg . "\n"; return $msg; } package Config::Model::Exception::LoadData; $Config::Model::Exception::LoadData::VERSION = '2.097'; use Mouse; extends 'Config::Model::Exception::User'; sub _desc { 'Load data structure (perl) error' }; has wrong_data => (is => 'rw', isa => 'Ref'); sub full_message { my $self = shift; my $obj = $self->object; my $location = defined $obj ? $obj->name : ''; my $msg = "Configuration item "; $msg .= "'$location' " if $location; $msg .= "(class " . $obj->config_class_name . ") " if $obj->get_type eq 'node'; $msg .= "has a " . $self->description; $msg .= ":\n\t" . $self->error_or_msg . "\n"; $msg .= Data::Dumper->Dump( [ $self->wrong_data ], ['wrong data'] ); return $msg; } package Config::Model::Exception::Model; $Config::Model::Exception::Model::VERSION = '2.097'; use Mouse; extends 'Config::Model::Exception::Fatal'; sub _desc { 'configuration model error'} sub full_message { my $self = shift; my $obj = $self->object; my $msg; if ( $obj->isa('Config::Model::Node') ) { $msg = "Node '" . $obj->name . "' of class " . $obj->config_class_name . ' '; } else { my $element = $obj->element_name; my $level = $obj->parent->get_element_property( element => $element, property => 'level' ); $msg = "In config class '" . $obj->parent->config_class_name . "', element '$element' (level $level) "; } $msg .= "has a " . $self->description; $msg .= ":\n\t" . $self->error_or_msg . "\n"; return $msg; } package Config::Model::Exception::Load; $Config::Model::Exception::Load::VERSION = '2.097'; use Mouse; extends 'Config::Model::Exception::User'; sub _desc { 'Load command error'} has command => (is => 'rw', isa => 'ArrayRef|Str'); sub full_message { my $self = shift; my $location = defined $self->object ? $self->object->name : ''; my $msg = $self->description; my $cmd = $self->command; no warnings 'uninitialized'; my $cmd_str = ref($cmd) ? join('',@$cmd) : $cmd ? "'$cmd'" : defined $cmd ? '' : ''; $msg .= " in node '$location' " if $location; $msg .= ':'; $msg .= "\n\tcommand: $cmd_str"; $msg .= "\n\t" . $self->error_or_msg . "\n"; return $msg; } package Config::Model::Exception::UnavailableElement; $Config::Model::Exception::UnavailableElement::VERSION = '2.097'; use Mouse; extends 'Config::Model::Exception::User'; sub _desc { 'unavailable element'} has [qw/element function/] => (is => 'rw', isa => 'Str'); sub full_message { my $self = shift; my $obj = $self->object; my $location = $obj->name; my $msg = $self->description; my $element = $self->element; my $function = $self->function; my $unavail = $obj->fetch_element( name => $element, check => 'no', accept_hidden => 1 ); $msg .= " '$element' in node '$location'.\n"; $msg .= "\tError occurred when calling $function.\n" if defined $function; $msg .= "\t" . $unavail->warp_error if $unavail->can('warp_error'); $msg .= "\t" . $self->info . "\n" if defined $self->info; return $msg; } package Config::Model::Exception::AncestorClass; $Config::Model::Exception::AncestorClass::VERSION = '2.097'; use Mouse; extends 'Config::Model::Exception::User'; sub _desc { 'unknown ancestor class'} package Config::Model::Exception::ObsoleteElement; $Config::Model::Exception::ObsoleteElement::VERSION = '2.097'; 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; $Config::Model::Exception::UnknownElement::VERSION = '2.097'; use Carp; use Mouse; extends 'Config::Model::Exception::User'; sub _desc { 'unknown element' } has [qw/element function where/] => (is => 'rw'); sub full_message { my $self = shift; my $obj = $self->object; confess "Exception::UnknownElement: object is ", ref($obj), ". Expected a node" unless ref($obj) && ($obj->isa('Config::Model::Node') || $obj->isa('Config::Model::WarpedNode')); my $class_name = $obj->config_class_name; # class_name is undef if the warped_node is warped out my @elements; @elements = $obj->get_element_name( class => $class_name, ) if defined $class_name; my $msg = ''; $msg .= "In " . $self->where . ": " if defined $self->where; $msg .= "(function '" . $self->function . "') " if defined $self->function; $msg = "object '" . $obj->name . "' error: " unless $msg; $msg .= $self->description . " '" . $self->element . "'."; $msg .= " Either your file has an error or $class_name model is lagging behind. " . "In the latter case, please submit a bug report or fix the model. See cme man " . "page for details.\n"; if (@elements) { $msg .= "\tExpected elements: '" . join( "','", @elements ) . "'\n"; } else { $msg .= " (node is warped out)\n"; } my @match_keys = $obj->can('accept_regexp') ? $obj->accept_regexp() : (); if (@match_keys) { $msg .= "\tor an acceptable parameter matching '" . join( "','", @match_keys ) . "'\n"; } # inform about available elements after a change of warp master value if ( defined $obj->parent ) { my $parent = $obj->parent; my $element_name = $obj->element_name; if ( $parent->element_type($element_name) eq 'warped_node' ) { $msg .= "\t" . $parent->fetch_element( name => $element_name, qw/master check no accept_hidden 1/ )->warp_error; } } $msg .= "\t" . $self->info . "\n" if ( defined $self->info ); return $msg; } package Config::Model::Exception::WarpError; $Config::Model::Exception::WarpError::VERSION = '2.097'; use Mouse; extends 'Config::Model::Exception::User'; sub _desc { 'warp error'} package Config::Model::Exception::Fatal; $Config::Model::Exception::Fatal::VERSION = '2.097'; use Mouse; extends 'Config::Model::Exception::Any'; sub _desc { 'fatal error' } package Config::Model::Exception::UnknownId; $Config::Model::Exception::UnknownId::VERSION = '2.097'; use Mouse; extends 'Config::Model::Exception::User'; sub _desc { 'unknown identifier'} has [qw/element id function where/] => (is => 'rw', isa => 'Str'); sub full_message { my $self = shift; my $obj = $self->object; my $element = $self->element; my $id_str = "'" . join( "','", $obj->fetch_all_indexes() ) . "'"; my $msg = ''; $msg .= "In function " . $self->function . ": " if defined $self->function; $msg .= "In " . $self->where . ": " if defined $self->where; $msg .= $self->description . " '" . $self->id() . "'" . " for element '" . $obj->location . "'\n\texpected: $id_str\n"; return $msg; } package Config::Model::Exception::WrongValue; $Config::Model::Exception::WrongValue::VERSION = '2.097'; use Mouse; extends 'Config::Model::Exception::User'; sub _desc { 'wrong value'}; package Config::Model::Exception::WrongType; $Config::Model::Exception::WrongType::VERSION = '2.097'; use Mouse; extends 'Config::Model::Exception::User'; sub _desc { 'wrong element type' }; has [qw/function got_type expected_type/] => (is => 'rw', isa => 'Str'); sub full_message { my $self = shift; my $obj = $self->object; my $msg = ''; $msg .= "In function " . $self->function . ": " if defined $self->function; $msg .= $self->description . " for element '" . $obj->location . "'\n\tgot type '" . $self->got_type . "', expected '" . $self->expected_type . "' " . $self->info . "\n"; return $msg; } package Config::Model::Exception::ConfigFile; $Config::Model::Exception::ConfigFile::VERSION = '2.097'; use Mouse; extends 'Config::Model::Exception::User'; sub _desc { 'error in configuration file' } package Config::Model::Exception::ConfigFile::Missing; $Config::Model::Exception::ConfigFile::Missing::VERSION = '2.097'; use Mouse; extends 'Config::Model::Exception::ConfigFile'; sub _desc { 'missing configuration file'} has tried_files => (is => 'rw', isa => 'ArrayRef'); sub full_message { my $self = shift; my $msg = "Error: cannot find configuration file " . join (' or ', @{ $self->tried_files }); return $msg . "\n"; } package Config::Model::Exception::Formula; $Config::Model::Exception::Formula::VERSION = '2.097'; use Mouse; extends 'Config::Model::Exception::Model'; sub _desc { 'error in computation formula of the configuration model'} package Config::Model::Exception::Internal; $Config::Model::Exception::Internal::VERSION = '2.097'; 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.097 =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-2016 by Dominique Dumont. This is free software, licensed under: The GNU Lesser General Public License, Version 2.1, February 1999 =cut Config-Model-2.097/lib/Config/Model/Role/0000755000175000017500000000000013027007223016350 5ustar domidomiConfig-Model-2.097/lib/Config/Model/Role/Grab.pm0000644000175000017500000003446013027007223017570 0ustar domidomi# # This file is part of Config-Model # # This software is Copyright (c) 2005-2016 by Dominique Dumont. # # This is free software, licensed under: # # The GNU Lesser General Public License, Version 2.1, February 1999 # package Config::Model::Role::Grab; $Config::Model::Role::Grab::VERSION = '2.097'; # ABSTRACT: Role to grab data from elsewhere in the tree use Mouse::Role; use strict; use warnings; use Carp; use Mouse::Util; use Log::Log4perl qw(get_logger :levels); my $logger = get_logger("Grab"); ## Navigation # accept commands like # item:b -> go down a node, create a new node if necessary # - climbs up # ! climbs up to the top # Now return an object and not a value ! sub grab { my $self = shift; my ( $steps, $mode, $autoadd, $type, $grab_non_available, $check ) = ( undef, 'strict', 1, undef, 0, 'yes' ); my %args = @_ > 1 ? @_ : ( steps => $_[0] ); $steps = delete $args{steps} // delete $args{step}; $mode = delete $args{mode} if defined $args{mode}; $autoadd = delete $args{autoadd} if defined $args{autoadd}; $grab_non_available = delete $args{grab_non_available} if defined $args{grab_non_available}; $type = delete $args{type}; # node, leaf or undef $check = $self->_check_check( delete $args{check} ); if ( defined $args{strict} ) { carp "grab: deprecated parameter 'strict'. Use mode"; $mode = delete $args{strict} ? 'strict' : 'adaptative'; } Config::Model::Exception::User->throw( object => $self, message => "grab: unexpected parameter: " . join( ' ', keys %args ) ) if %args; Config::Model::Exception::Internal->throw( error => "grab: steps parameter must be a string " . "or an array ref" ) unless ref $steps eq 'ARRAY' || not ref $steps; # accept commands, grep remove empty items left by spurious spaces my $huge_string = ref $steps ? join( ' ', @$steps ) : $steps; my @command = ( $huge_string =~ m/ ( # begin of *one* command (?: # group parts of a command (e.g ...:... ) [^\s"]+ # match anything but a space and a quote (?: # begin quoted group " # begin of a string (?: # begin group \\" # match an escaped quote | # or [^"] # anything but a quote )* # lots of time " # end of the string ) # end of quoted group ? # match if I got more than one group )+ # can have several parts in one command ) # end of *one* command /gx ); my @saved = @command; $logger->debug( "grab: executing '", join( "' '", @command ), "' on object '", $self->name, "'" ); my @found = ($self); COMMAND: while (@command) { last if $mode eq 'step_by_step' and @saved > @command; my $cmd = shift @command; my $obj = $found[-1]; $logger->debug( "grab: executing cmd '$cmd' on object '", $obj->name, "($obj)'" ); if ( $cmd eq '!' ) { push @found, $obj->grab_root(); next; } if ( $cmd =~ /^!([\w:]*)/ ) { my $ancestor = $obj->grab_ancestor($1); if ( defined $ancestor ) { push @found, $ancestor; next; } else { Config::Model::Exception::AncestorClass->throw( object => $obj, info => "grab called from '" . $self->name . "' with steps '@saved' looking for class $1" ) if $mode eq 'strict'; return; } } if ( $cmd =~ /^\?(\w[\w-]*)/ ) { push @found, $obj->grab_ancestor_with_element_named($1); $cmd =~ s/^\?//; #remove the go up part unshift @command, $cmd; next; } if ( $cmd eq '-' ) { if ( defined $obj->parent ) { push @found, $obj->parent; next; } else { $logger->debug( "grab: ", $obj->name, " has no parent" ); return $mode eq 'adaptative' ? $obj : undef; } } unless ( $obj->isa('Config::Model::Node') or $obj->isa('Config::Model::WarpedNode') ) { Config::Model::Exception::Model->throw( object => $obj, message => "Cannot apply command '$cmd' on leaf item" . " (full command is '@saved')" ); } my ( $name, $action, $arg ) = ( $cmd =~ /(\w[\-\w]*)(?:(:)((?:"[^\"]*")|(?:[\w:\/\.\-\+]+)))?/ ); if ( defined $arg and $arg =~ /^"/ and $arg =~ /"$/ ) { $arg =~ s/^"//; # remove leading quote $arg =~ s/"$//; # remove trailing quote } { no warnings "uninitialized"; $logger->debug("grab: cmd '$cmd' -> name '$name', action '$action', arg '$arg'"); } unless ( $obj->has_element($name) ) { if ( $mode eq 'step_by_step' ) { return wantarray ? ( undef, @command ) : undef; } elsif ( $mode eq 'loose' ) { return; } elsif ( $mode eq 'adaptative' ) { last; } else { Config::Model::Exception::UnknownElement->throw( object => $obj, element => $name, function => 'grab', info => "grab called from '" . $self->name . "' with steps '@saved'" ); } } unless ( $grab_non_available or $obj->is_element_available( name => $name, ) ) { if ( $mode eq 'step_by_step' ) { return wantarray ? ( undef, @command ) : undef; } elsif ( $mode eq 'loose' ) { return; } elsif ( $mode eq 'adaptative' ) { last; } else { Config::Model::Exception::UnavailableElement->throw( object => $obj, element => $name, function => 'grab', info => "grab called from '" . $self->name . "' with steps '@saved'" ); } } my $next_obj = $obj->fetch_element( name => $name, check => $check, accept_hidden => $grab_non_available ); # create list or hash element only if autoadd is true if ( defined $action and $autoadd == 0 and not $next_obj->exists($arg) ) { return if $mode eq 'loose'; Config::Model::Exception::UnknownId->throw( object => $obj->fetch_element($name), element => $name, id => $arg, function => 'grab' ) unless $mode eq 'adaptative'; last; } if ( defined $action and not $next_obj->isa('Config::Model::AnyId') ) { return if $mode eq 'loose'; Config::Model::Exception::Model->throw( object => $obj, message => "Cannot apply command '$cmd' on non hash or non list item" . " (full command is '@saved'). item is '" . $next_obj->name . "'" ); last; } # action can only be : $next_obj = $next_obj->fetch_with_id(index => $arg, check => $check) if defined $action; push @found, $next_obj; } # check element type if ( defined $type ) { my @allowed = ref $type ? @$type : ($type); while ( @found and not grep {$found[-1]->get_type eq $_} @allowed ) { Config::Model::Exception::WrongType->throw( object => $found[-1], function => 'grab', got_type => $found[-1]->get_type, expected_type => $type, info => "requested with steps '$steps'" ) if $mode ne 'adaptative'; pop @found; } } my $return = $found[-1]; $logger->debug( "grab: returning object '", $return->name, "($return)'" ); return wantarray ? ( $return, @command ) : $return; } sub grab_value { my $self = shift; my %args = scalar @_ == 1 ? ( steps => $_[0] ) : @_; my $obj = $self->grab(%args); # Pb: may return a node. add another option to grab ?? # to get undef value when needed? return if ( $args{mode} and $args{mode} eq 'loose' and not defined $obj ); Config::Model::Exception::User->throw( object => $self, message => "grab_value: cannot get value of non-leaf or check_list " . "item with '" . join( "' '", @_ ) . "'. item is $obj" ) unless ref $obj and ( $obj->isa("Config::Model::Value") or $obj->isa("Config::Model::CheckList") ); my $value = $obj->fetch; if ( $logger->is_debug ) { my $str = defined $value ? $value : ''; $logger->debug( "grab_value: returning value $str of object '", $obj->name ); } return $value; } sub grab_annotation { my $self = shift; my @args = scalar @_ == 1 ? ( steps => $_[0] ) : @_; my $obj = $self->grab(@args); return $obj->annotation; } sub grab_root { my $self = shift; return defined $self->parent ? $self->parent->grab_root : $self; } sub grab_ancestor { my $self = shift; my $class = shift || die "grab_ancestor: missing ancestor class"; return $self if $self->get_type eq 'node' and $self->config_class_name eq $class; return $self->{parent}->grab_ancestor($class) if defined $self->{parent}; return; } #internal. Used by grab with '?xxx' steps sub grab_ancestor_with_element_named { my ( $self, $search, $type ) = @_; my $obj = $self; while (1) { $logger->debug( "grab_ancestor_with_element_named: executing cmd '?$search' on object " . $obj->name ); my $obj_element_name = $obj->element_name; if ( $obj->isa('Config::Model::Node') and $obj->has_element( name => $search, type => $type ) ) { # object contains the search element, we need to grab the # searched object (i.e. the '?foo' part is done return $obj; } elsif ( defined $obj->parent ) { # going up $obj = $obj->parent; } else { # there's no more up to go to... Config::Model::Exception::Model->throw( object => $self, error => "Error: cannot grab '?$search'" . "from " . $self->name ); } } } __END__ =pod =encoding UTF-8 =head1 NAME Config::Model::Role::Grab - Role to grab data from elsewhere in the tree =head1 VERSION version 2.097 =head1 SYNOPSIS $self->load_node( config_class_name => "...", %other_args); =head1 DESCRIPTION Role used to let a tree item (i.e. node, hash, list or leaf) to grab another item or value from the configuration tree using a path (a bit like an xpath path with a different syntax). =head1 METHODS =head2 grab Grab an object from the configuration tree. Parameters are: =over =item C (or C) A string indicating the steps to follow in the tree to find the required item. (mandatory) =item C When set to C, C throws an exception if no object is found using the passed string. When set to C, the object found last is returned. For instance, for the steps C, only the object held by C is returned. When set to C, grab returns undef in case of problem. (default is C) =item C Either C, C, C or C or an array ref containing these values. Returns only an object of requested type. Depending on C value, C either throws an exception or returns the last object found with the requested type. (optional, default to C, which means any type of object) Examples: $root->grep(steps => 'foo:2 bar', type => 'leaf') $root->grep(steps => 'foo:2 bar', type => ['leaf','check_list']) =item C When set to 1, C or C configuration element are created when requested by the passed steps. (default is 1). =item grab_non_available When set to 1, grab returns an object even if this one is not available. I.e. even if this element was warped out. (default is 0). =back The C parameters is made of the following items separated by spaces: =over 8 =item - Go up one node =item ! Go to the root node. =item !Foo Go up the configuration tree until the C configuration class is found. Raise an exception if no C class is found when root node is reached. =item xxx Go down using C element. =item xxx:yy Go down using C element and id C (valid for hash or list elements) =item ?xxx Go up the tree until a node containing element C is found. Then go down the tree like item C. If C, go up the tree the same way. But no check is done to see if id C actually exists or not. Only the element C is considered when going up the tree. =back =head2 grab_value Like L, but returns the value of a leaf or check_list object, not just the leaf object. C raises an exception if following the steps ends on anything but a leaf or a check_list. =head2 grab_annotation Like L, but returns the annotation of an object. =head2 grab_root Returns the root of the configuration tree. =head2 grab_ancestor Parameter: a configuration class name Go up the configuration tree until a node using the configuration class is found. Returns the found node or undef. Example: # returns a Config::Model::Node object for a Systemd::Service config class $self->grab('Systemd::Service'); =head1 AUTHOR Dominique Dumont =head1 COPYRIGHT AND LICENSE This software is Copyright (c) 2005-2016 by Dominique Dumont. This is free software, licensed under: The GNU Lesser General Public License, Version 2.1, February 1999 =cut Config-Model-2.097/lib/Config/Model/Role/HelpAsText.pm0000644000175000017500000000341013027007223020725 0ustar domidomi# # This file is part of Config-Model # # This software is Copyright (c) 2005-2016 by Dominique Dumont. # # This is free software, licensed under: # # The GNU Lesser General Public License, Version 2.1, February 1999 # package Config::Model::Role::HelpAsText; $Config::Model::Role::HelpAsText::VERSION = '2.097'; # ABSTRACT: Transalet element help from pod to text use Mouse::Role; use strict; use warnings; use Pod::Text; use Pod::Simple 3.23; use 5.10.1; requires('get_help'); sub get_help_as_text { my $self = shift; my $pod = $self->get_help(@_) ; return undef unless defined $pod; my $parser = Pod::Text->new( indent => 0, nourls => 1, ); # require Pod::Simple 3.23 $parser->parse_characters('utf8'); my $output = ''; $parser->output_string(\$output); $parser->parse_string_document("=pod\n\n" . $pod); $output =~ s/[\n\s]+$//; return $output; } 1; __END__ =pod =encoding UTF-8 =head1 NAME Config::Model::Role::HelpAsText - Transalet element help from pod to text =head1 VERSION version 2.097 =head1 SYNOPSIS $self->get_help_as_text( ... ); =head1 DESCRIPTION Role used to transform Config::Model help text or description from pod to text. The provided method should be used when the help text should be displayed on STDOUT. This functionality is provided as a role because the interface to L is not so easy. =head1 METHODS =head2 get_help_as_text Calls C and transform the Pod output to text. =head2 SEE ALSO L, L =head1 AUTHOR Dominique Dumont =head1 COPYRIGHT AND LICENSE This software is Copyright (c) 2005-2016 by Dominique Dumont. This is free software, licensed under: The GNU Lesser General Public License, Version 2.1, February 1999 =cut Config-Model-2.097/lib/Config/Model/Role/WarpMaster.pm0000644000175000017500000001007713027007223021000 0ustar domidomi# # This file is part of Config-Model # # This software is Copyright (c) 2005-2016 by Dominique Dumont. # # This is free software, licensed under: # # The GNU Lesser General Public License, Version 2.1, February 1999 # package Config::Model::Role::WarpMaster; $Config::Model::Role::WarpMaster::VERSION = '2.097'; # ABSTRACT: register and trigger a warped element use Mouse::Role; use strict; use warnings; use Mouse::Util; use Log::Log4perl qw(get_logger :levels); use Scalar::Util qw/weaken/; my $logger = get_logger("Warper"); has 'warp_these_objects' => ( traits => ['Array'], is => 'ro', isa => 'ArrayRef', default => sub { [] }, handles => { _slave_info => 'elements', _add_slave_info => 'push', _delete_slave => 'delete', has_warped_slaves => 'count', # find_slave_idx => 'first_index', not available in Mouse }, ); sub register { my ( $self, $warped, $warper_name ) = @_; my $w_name = $warped->name; $logger->debug( $self->get_type . ": " . $self->name, " registered $w_name ($warper_name)" ) if $logger->is_debug; # weaken only applies to the passed reference, and there's no way # to duplicate a weak ref. Only a strong ref is created. See # qw(weaken) module for weaken() my @tmp = ( $warped, $w_name, $warper_name ); weaken( $tmp[0] ); $self->_add_slave_info( \@tmp ); return defined $self->{compute} ? 'computed' : 'regular'; } sub unregister { my ( $self, $w_name ) = @_; $logger->debug( $self->get_type .": " . $self->name, " unregister $w_name" ) if $logger->is_debug; my $idx = 0; foreach my $info ($self->_slave_info) { last if $info->[0] eq $w_name ; $idx++; } $self->_delete_slave($idx); } # And I'm going to warp them ... sub trigger_warp { my $self = shift; my $value = shift; my $str_val = shift // $value // 'undefined'; foreach my $ref ( $self->_slave_info ) { my ( $warped, $w_name, $warp_index ) = @$ref; next unless defined $warped; # $warped is a weak ref and may vanish # pure warp of object if ($logger->is_debug) { $logger->debug("trigger_warp: ".$self->get_type." ", $self->name, " warps '$w_name' with value <$str_val> "); } $warped->trigger( $value, $warp_index ); } } sub get_warped_slaves { my $self = shift; # grep is used to clean up weak ref to object that were destroyed return grep { defined $_ } map { $_->[0] } $self->_slave_info; } 1; __END__ =pod =encoding UTF-8 =head1 NAME Config::Model::Role::WarpMaster - register and trigger a warped element =head1 VERSION version 2.097 =head1 SYNOPSIS package Config::Model::Stuff; use Mouse; with Config::Model::Role::WarpMaster =head1 DESCRIPTION This role enable a configuration element to become a warp maser, i.e. a parameter whose value can change the features of the configuration tree (by controlling a warped_node) or the feature of various elements like leaf, hash ... =head1 METHODS =head2 register ( $warped_object, warper_name ) Register a new warped object. Called by an element which has a C parameter. This method is calling on the object pointed by C value. =head2 unregister ( warper_name ) Remove a warped object from the object controlled by this warp master. =head2 trigger_warp ( value, stringified_value ) Called by the object using this role when the value held by this object is changed (i.e. something like store was called). The passed value can be a plain scalar (from a value object) or a hash (from a check_list object). The stringified_value is a string shown in debug log. -head2 has_warped_slaves Return the number of object controlled by this master. =head2 get_warped_slaves Return a list of object controlled by this master. =head1 AUTHOR Dominique Dumont =head1 COPYRIGHT AND LICENSE This software is Copyright (c) 2005-2016 by Dominique Dumont. This is free software, licensed under: The GNU Lesser General Public License, Version 2.1, February 1999 =cut Config-Model-2.097/lib/Config/Model/Role/NodeLoader.pm0000644000175000017500000000343413027007223020726 0ustar domidomi# # This file is part of Config-Model # # This software is Copyright (c) 2005-2016 by Dominique Dumont. # # This is free software, licensed under: # # The GNU Lesser General Public License, Version 2.1, February 1999 # package Config::Model::Role::NodeLoader; $Config::Model::Role::NodeLoader::VERSION = '2.097'; # ABSTRACT: Load Node element in configuration tree use Mouse::Role; use strict; use warnings; use Mouse::Util; use Log::Log4perl qw(get_logger :levels); my $load_logger = get_logger("TreeLoad"); sub load_node { my ($self, %params) = @_ ; my $config_class_name = $params{config_class_name}; my $config_class = $self->config_model->get_model($config_class_name) ; my $node_class = $config_class->{class} || 'Config::Model::Node'; $load_logger->info("Loading $config_class_name ". $self->location . " with $node_class"); Mouse::Util::load_class($node_class); return $node_class->new(%params) ; } __END__ =pod =encoding UTF-8 =head1 NAME Config::Model::Role::NodeLoader - Load Node element in configuration tree =head1 VERSION version 2.097 =head1 SYNOPSIS $self->load_node( config_class_name => "...", %other_args); =head1 DESCRIPTION Role used to load a node element using L (default behavior). If the config class overrides the default implementation, ( C parameter ), the override class is loaded and used to create the node. =head1 METHODS =head2 load_node Creates a node object using all the named parameters passed to load_node. One of these parameter must be C =head1 AUTHOR Dominique Dumont =head1 COPYRIGHT AND LICENSE This software is Copyright (c) 2005-2016 by Dominique Dumont. This is free software, licensed under: The GNU Lesser General Public License, Version 2.1, February 1999 =cut Config-Model-2.097/lib/Config/Model/Lister.pm0000644000175000017500000000661313027007223017255 0ustar domidomi# # This file is part of Config-Model # # This software is Copyright (c) 2005-2016 by Dominique Dumont. # # This is free software, licensed under: # # The GNU Lesser General Public License, Version 2.1, February 1999 # package Config::Model::Lister; $Config::Model::Lister::VERSION = '2.097'; use strict; use warnings; use Exporter; use vars qw/@EXPORT/; @EXPORT = qw(applications models); sub available_models { my $test = shift || 0; my ( %categories, %appli_info, %applications ); my %done_cat; my @dir_to_scan = $test ? qw/lib/ : @INC; foreach my $dir ( map { glob("$_/Config/Model/*.d") } @dir_to_scan ) { my ($cat) = ( $dir =~ m!.*/([\w\-]+)\.d! ); if ( $cat !~ /^user|system|application$/ ) { warn "available_models: skipping unexpected category: $cat\n"; next; } foreach my $file ( sort glob("$dir/*") ) { next if $file =~ m!/README!; next if $file =~ /(~|\.bak|\.orig)$/; my ($appli) = ( $file =~ m!.*/([\w\-]+)! ); $appli_info{$appli}{_file} = $file; $appli_info{$appli}{_category} = $cat; open( F, $file ) || die "Can't open file $file:$!"; while () { chomp; s/^\s+//; s/\s+$//; s/#.*//; my ( $k, $v ) = split /\s*=\s*/; next unless $v; if ( $k =~ /model/i ) { push @{ $categories{$cat} }, $appli unless $done_cat{$cat}{$appli}; $done_cat{$cat}{$appli} = 1; } $appli_info{$appli}{$k} = $v; $applications{$appli} = $v if $k =~ /model/i; } } } return \%categories, \%appli_info, \%applications; } sub models { my @i = available_models(@_); return join( ' ', sort values %{ $i[2] } ) . "\n"; } sub applications { my @i = available_models(@_); return join( ' ', sort keys %{ $i[2] } ) . "\n"; } 1; # ABSTRACT: List available models and applications __END__ =pod =encoding UTF-8 =head1 NAME Config::Model::Lister - List available models and applications =head1 VERSION version 2.097 =head1 SYNOPSIS perl -MConfig::Model::Lister -e'print Config::Model::Lister::models;' perl -MConfig::Model::Lister -e'print Config::Model::Lister::applications;' =head1 DESCRIPTION Small modules to list available models or applications whose config can be edited by L. This module is designed to be used by bash completion. All functions accept an optional boolean parameter. When true, only the local C dir is scanned. =head1 FUNCTIONS =head1 available_models Returns an array of 3 hash refs: =over =item * category (system or user or application) => application list. E.g. { system => [ 'popcon' , 'fstab'] } =item * application name to model information. E.g. { 'multistrap' => { model => 'Multistrap', require_config_file => 1 } =item * application name to model name. E.g. { popcon => 'Popcon', 'multistrap' => 'Multistrap' } =back =head1 models Returns a string with the list of models. =head1 applications Returns a string with the list of editable applications. =head1 AUTHOR Dominique Dumont =head1 COPYRIGHT AND LICENSE This software is Copyright (c) 2005-2016 by Dominique Dumont. This is free software, licensed under: The GNU Lesser General Public License, Version 2.1, February 1999 =cut Config-Model-2.097/lib/Config/Model/ObjTreeScanner.pm0000644000175000017500000004664313027007223020666 0ustar domidomi# # This file is part of Config-Model # # This software is Copyright (c) 2005-2016 by Dominique Dumont. # # This is free software, licensed under: # # The GNU Lesser General Public License, Version 2.1, February 1999 # package Config::Model::ObjTreeScanner; $Config::Model::ObjTreeScanner::VERSION = '2.097'; use strict; use Config::Model::Exception; use Scalar::Util qw/blessed/; use Carp::Assert::More; use Carp; use warnings; use Carp qw/croak confess cluck/; sub new { my $type = shift; my %args = @_; my $self = { auto_vivify => 1, check => 'yes' }; bless $self, $type; $self->{leaf_cb} = delete $args{leaf_cb} or croak __PACKAGE__, "->new: missing leaf_cb parameter"; # we may use leaf_cb $self->create_fallback( delete $args{fallback} || 'all' ); # get all call_backs my @value_cb = map { $_ . '_value_cb' } qw/boolean enum string uniline integer number reference/; foreach my $param ( qw/check node_element_cb hash_element_cb list_element_cb check_list_element_cb node_content_cb node_content_hook list_element_hook hash_element_hook auto_vivify up_cb/, @value_cb ) { $self->{$param} = $args{$param} if defined $args{$param}; delete $args{$param}; # may exists but be undefined croak __PACKAGE__, "->new: missing $param parameter" unless defined $self->{$param}; } if (delete $args{experience}) { carp "->new: experience parameter is deprecated"; } # this parameter is optional and does not need a fallback $self->{node_dispatch_cb} = delete $args{node_dispatch_cb} || {}; croak __PACKAGE__, "->new: node_dispatch_cb is not a hash ref" unless ref( $self->{node_dispatch_cb} ) eq 'HASH'; croak __PACKAGE__, "->new: unexpected check: $self->{check}" unless $self->{check} =~ /yes|no|skip/; croak __PACKAGE__, "->new: unexpected parameter: ", join( ' ', keys %args ) if scalar %args; return $self; } # internal sub create_fallback { my $self = shift; my $fallback = shift; map { $self->{$_} = sub { } } qw/node_content_hook hash_element_hook list_element_hook/; return if not defined $fallback or $fallback eq 'none'; my $done = 0; if ( $fallback eq 'node' or $fallback eq 'all' ) { $done++; my $node_content_cb = sub { my ( $scanner, $data_r, $node, @element ) = @_; map { $scanner->scan_element( $data_r, $node, $_ ) } @element; }; my $node_element_cb = sub { my ( $scanner, $data_r, $node, $element_name, $key, $next_node ) = @_; $scanner->scan_node( $data_r, $next_node ); }; my $hash_element_cb = sub { my ( $scanner, $data_r, $node, $element_name, @keys ) = @_; map { $scanner->scan_hash( $data_r, $node, $element_name, $_ ) } @keys; }; $self->{list_element_cb} = $hash_element_cb; $self->{hash_element_cb} = $hash_element_cb; $self->{node_element_cb} = $node_element_cb; $self->{node_content_cb} = $node_content_cb; $self->{up_cb} = sub { }; # do nothing } if ( $fallback eq 'leaf' or $fallback eq 'all' ) { $done++; my $l = $self->{string_value_cb} ||= $self->{leaf_cb}; $self->{check_list_element_cb} ||= $l; $self->{enum_value_cb} ||= $l; $self->{integer_value_cb} ||= $l; $self->{number_value_cb} ||= $l; $self->{boolean_value_cb} ||= $l; $self->{reference_value_cb} ||= $l; $self->{uniline_value_cb} ||= $l; } croak __PACKAGE__, "->new: Unexpected fallback value '$fallback'. ", "Expected 'node', 'leaf', 'all' or 'none'" if not $done; } sub scan_node { my ( $self, $data_r, $node ) = @_; #print "scan_node ",$node->name,"\n"; # get all elements according to catalog Config::Model::Exception::Internal->throw( error => "'$node' is not a Config::Model object" ) unless blessed($node) and $node->isa("Config::Model::AnyThing"); # skip exploration of warped out node if ( $node->isa('Config::Model::WarpedNode') ) { $node = $node->get_actual_node; return unless defined $node; } my $config_class = $node->config_class_name; my $node_dispatch_cb = $self->{node_dispatch_cb}{$config_class}; my $actual_cb = $node_dispatch_cb || $self->{node_content_cb}; my @element_list = $node->get_element_name( check => $self->{check} ); $self->{node_content_hook}->( $self, $data_r, $node, @element_list ); # we could add here a "last element" call-back, but it's not # very useful if the last element is a hash. $actual_cb->( $self, $data_r, $node, @element_list ); $self->{up_cb}->( $self, $data_r, $node ); } sub scan_element { my ( $self, $data_r, $node, $element_name ) = @_; my $element_type = $node->element_type($element_name); my $autov = $self->{auto_vivify}; #print "scan_element $element_name "; if ( $element_type eq 'hash' ) { #print "type hash\n"; my @keys = $self->get_keys( $node, $element_name ); # if hash element grab keys and perform callback $self->{hash_element_hook}->( $self, $data_r, $node, $element_name, @keys ); $self->{hash_element_cb}->( $self, $data_r, $node, $element_name, @keys ); } elsif ( $element_type eq 'list' ) { #print "type list\n"; my @keys = $self->get_keys( $node, $element_name ); $self->{list_element_hook}->( $self, $data_r, $node, $element_name, @keys ); $self->{list_element_cb}->( $self, $data_r, $node, $element_name, @keys ); } elsif ( $element_type eq 'check_list' ) { #print "type list\n"; my $cl_elt = $node->fetch_element( name => $element_name, check => $self->{check} ); $self->{check_list_element_cb}->( $self, $data_r, $node, $element_name, undef, $cl_elt ); } elsif ( $element_type eq 'node' ) { #print "type object\n"; # avoid auto-vivification my $next_obj = ( $autov or $node->is_element_defined($element_name) ) ? $node->fetch_element( name => $element_name, check => $self->{check} ) : undef; # if obj element, cb $self->{node_element_cb}->( $self, $data_r, $node, $element_name, undef, $next_obj ); } elsif ( $element_type eq 'warped_node' ) { #print "type warped\n"; my $next_obj = ( $autov or $node->is_element_defined($element_name) ) ? $node->fetch_element( name => $element_name, check => $self->{check} ) : undef; $self->{node_element_cb}->( $self, $data_r, $node, $element_name, undef, $next_obj ); } elsif ( $element_type eq 'leaf' ) { my $next_obj = $node->fetch_element( name => $element_name, check => $self->{check} ); my $type = $next_obj->value_type; return unless $type; my $cb_name = $type . '_value_cb'; my $cb = $self->{$cb_name}; croak "scan_element: No call_back specified for '$cb_name'" unless defined $cb; $cb->( $self, $data_r, $node, $element_name, undef, $next_obj ); } else { croak "Unexpected element_type: $element_type"; } } sub scan_hash { my ( $self, $data_r, $node, $element_name, $key ) = @_; assert_like( $node->element_type($element_name), qr/(hash|list)/ ); #print "scan_hash ",$node->name," element $element_name key $key "; my $item = $node->fetch_element( name => $element_name, check => $self->{check} ); my $cargo_type = $item->cargo_type($element_name); my $next_obj = $item->fetch_with_id( index => $key, check => $self->{check} ); if ( $cargo_type =~ /node$/ ) { #print "type object or warped\n"; $self->{node_element_cb}->( $self, $data_r, $node, $element_name, $key, $next_obj ); } elsif ( $cargo_type eq 'leaf' ) { my $cb_name = $next_obj->value_type . '_value_cb'; my $cb = $self->{$cb_name}; croak "scan_hash: No call_back specified for '$cb_name'" unless defined $cb; $cb->( $self, $data_r, $node, $element_name, $key, $next_obj ); } else { croak "Unexpected cargo_type: $cargo_type"; } } sub scan_list { goto &scan_hash; } sub get_keys { my ( $self, $node, $element_name ) = @_; my $element_type = $node->element_type($element_name); my $item = $node->fetch_element( name => $element_name, check => $self->{check} ); return $item->fetch_all_indexes if $element_type eq 'hash' || $element_type eq 'list'; Config::Model::Exception::Internal->throw( error => "called get_keys on non hash or non list" . " element $element_name", object => $node ); } 1; # ABSTRACT: Scan config tree and perform call-backs for each element or node __END__ =pod =encoding UTF-8 =head1 NAME Config::Model::ObjTreeScanner - Scan config tree and perform call-backs for each element or node =head1 VERSION version 2.097 =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 ) ; # define leaf call back my $disp_leaf = sub { my ($scanner, $data_ref, $node,$element_name,$index, $leaf_object) = @_ ; $$data_ref .= "disp_leaf called for '". $leaf_object->name. "' value '".$leaf_object->fetch."'\n"; } ; # simple scanner, (print all values) my $scan = Config::Model::ObjTreeScanner-> new ( leaf_cb => $disp_leaf, # only mandatory parameter ) ; my $result = ''; $scan->scan_node(\$result, $root) ; print $result ; =head1 DESCRIPTION This module creates an object that explores (depth first) a configuration tree. For each part of the configuration tree, ObjTreeScanner object calls one of the subroutine reference passed during construction. (a call-back or a hook) Call-back and hook routines are called: =over =item * For each node containing elements (including root node) =item * For each element of a node. This element can be a list, hash, node or leaf element. =item * For each item contained in a node, hash or list. This item can be a leaf or another node. =back To continue the exploration, these call-backs must also call the scanner. (i.e. perform another call-back). In other words the user's subroutine and the scanner play a game of ping-pong until the tree is completely explored. Hooks routines are not required to resume the exploration, i.e. to call the scanner. This is done once the hook routine has returned. The scanner provides a set of default callback for the nodes. This way, the user only have to provide call-backs for the leaves. The scan is started with a call to C. The first parameter of scan_node is a ref that is passed untouched to all call-back. This ref may be used to store whatever result you want. =head1 CONSTRUCTOR =head2 new ( ... ) One way or another, the ObjTreeScanner object must be able to find all callback for all the items of the tree. All the possible call-back and hooks are listed below: =over =item leaf callback: C is a catch-all generic callback. All other are specialized call-back : C, C, C, C, C, C, C =item node callback: C , C =item node hooks: C =item element callback: All these call-backs are called on the elements of a node: C, C, C, C, C. =item element hooks: C, C. =back The user may specify all of them by passing a sub ref to the constructor: $scan = Config::Model::ObjTreeScanner-> new ( list_element_cb => sub { ... }, ... ) Or use some default callback using the fallback parameter. Note that at least one callback must be provided: C. Optional parameter: =over =item fallback If set to C, the scanner provides default call-back for node items. If set to C, the scanner sets all leaf callback (like enum_value_cb ...) to string_value_cb or to the mandatory leaf_cb value. "fallback" callback does not override callbacks provided by the user. If set to C , the scanner provides fallbacks for leaf and node. By default, all fallback are provided. =item auto_vivify Whether to create configuration objects while scanning (default is 1). =item check C, C or C. =back =head1 Callback prototypes =head2 Leaf callback C is called for each leaf of the tree. The leaf callback is called with the following parameters: ($scanner, $data_ref,$node,$element_name,$index, $leaf_object) where: =over =item * C<$scanner> is the scanner object. =item * C<$data_ref> is a reference that is first passed to the first call of the scanner. Then C<$data_ref> is relayed through the various call-backs =item * C<$node> is the node that contain the leaf. =item * C<$element_name> is the element (or attribute) that contain the leaf. =item * C<$index> is the index (or hash key) used to get the leaf. This may be undefined if the element type is scalar. =item * C<$leaf_object> is a L object. =back =head2 List element callback C is called on all list element of a node, i.e. call on the list object itself and not in the elements contained in the list. ($scanner, $data_ref,$node,$element_name,@indexes) C<@indexes> is a list containing all the indexes of the list. Example: sub my_list_element_cb { my ($scanner, $data_ref,$node,$element_name,@idx) = @_ ; # custom code using $data_ref # resume exploration (if needed) map {$scanner->scan_list($data_ref,$node,$element_name,$_)} @idx ; # note: scan_list and scan_hash are equivalent } =head2 List element hook C: Works like the list element callback. Except that the calls to C are not required. This is done once the hook returns. =head2 Check list element callback C: Like C, but called on a check_list element. ($scanner, $data_ref,$node,$element_name,@check_items) C<@check_items> is a list containing all the items of the check_list. =head2 Hash element callback C: Like C, but called on a hash element. ($scanner, $data_ref,$node,$element_name,@keys) C<@keys> is an list containing all the keys of the hash. Example: sub my_hash_element_cb { my ($scanner, $data_ref,$node,$element_name,@keys) = @_ ; # custom code using $data_ref # resume exploration map {$scanner->scan_hash($data_ref,$node,$element_name,$_)} @keys ; } =head2 Hash element hook C: Works like the hash element callback. Except that the calls to C are not required. This is done once the hook returns. =head2 Node content callback C: This call-back is called foreach node (including root node). ($scanner, $data_ref,$node,@element_list) C<@element_list> contains all the element names of the node. Example: sub my_content_cb { my ($scanner, $data_ref,$node,@element) = @_ ; # custom code using $data_ref # resume exploration map {$scanner->scan_element($data_ref, $node,$_)} @element ; } =head2 Node content hook C: This hook is called foreach node (including root node). Works like the node content call-back. Except that the calls to C are not required. This is done once the hook returns. =head2 Dispatch node callback C: Any callback specified in the hash is called for each instance of the specified configuration class. (this may include the root node). For instance, if you have: node_dispach_cb => { ClassA => \&my_class_a_dispatch_cb, ClassB => \&my_class_b_dispatch_cb, } C<&my_class_a_dispatch_cb> is called for each instance of C and C<&my_class_b_dispatch_cb> is called for each instance of C. They is called with the following parameters: ($scanner, $data_ref,$node,@element_list) C<@element_list> contains all the element names of the node. Example: sub my_class_a_dispatch_cb = { my ($scanner, $data_ref,$node,@element) = @_ ; # custom code using $data_ref # resume exploration map {$scanner->scan_element($data_ref, $node,$_)} @element ; } =head2 Node element callback C is called for each node contained within a node (i.e not with root node). This node can be held by a plain element or a hash element or a list element: ($scanner, $data_ref,$node,$element_name,$key, $contained_node) C<$key> may be undef if C<$contained_node> is not a part of a hash or a list. C<$element_name> and C<$key> specifies the element name and key of the the contained node you want to scan. (passed with C<$contained_node>) Note that C<$contained_node> may be undef if C is 0. Example: sub my_node_element_cb { my ($scanner, $data_ref,$node,$element_name,$key, $contained_node) = @_; # your custom code using $data_ref # explore next node $scanner->scan_node($data_ref,$contained_node); } =head1 METHODS =head2 scan_node ($data_r,$node) Explore the node and call either C (if the node class name matches the dispatch_node hash) B (e.g. xor) C passing all element names. C is called once the first callback returns. =head2 scan_element($data_r,$node,$element_name) Explore the element and call either C, C, C or a leaf call-back (the leaf call-back called depends on the Value object properties: enum, string, integer and so on) =head2 scan_hash ($data_r,$node,$element_name,$key) Explore the hash member (or hash value) and call either C or a leaf call-back. =head2 scan_list ($data_r,$node,$element_name,$index) Just like C: Explore the list member and call either C or a leaf call-back. =head2 get_keys ($node, $element_name) Returns an list containing the sorted keys of a hash element or returns an list containing (0.. last_index) of an list element. Throws an exception if element is not an list or a hash element. =head1 AUTHOR Dominique Dumont, (ddumont at cpan dot org) =head1 SEE ALSO L,L,L, L, L, L, L =head1 AUTHOR Dominique Dumont =head1 COPYRIGHT AND LICENSE This software is Copyright (c) 2005-2016 by Dominique Dumont. This is free software, licensed under: The GNU Lesser General Public License, Version 2.1, February 1999 =cut Config-Model-2.097/lib/Config/Model/CheckList.pm0000644000175000017500000007451313027007223017670 0ustar domidomi# # This file is part of Config-Model # # This software is Copyright (c) 2005-2016 by Dominique Dumont. # # This is free software, licensed under: # # The GNU Lesser General Public License, Version 2.1, February 1999 # package Config::Model::CheckList; $Config::Model::CheckList::VERSION = '2.097'; 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"; my $logger = get_logger("Tree::Element::CheckList"); my @introspect_params = qw/refer_to computed_refer_to/; my @accessible_params = qw/default_list upstream_default_list choice ordered/; my @allowed_warp_params = ( @accessible_params, qw/level/ ); has [qw/backup data preset layered/] => ( is => 'rw', isa => 'HashRef', default => sub { {}; } ); has computed_refer_to => ( is => 'rw', isa => 'Maybe[HashRef]' ); has [qw/refer_to/] => ( is => 'rw', isa => 'Str' ); has [qw/ordered_data choice/] => ( is => 'rw', isa => 'ArrayRef', default => sub { []; } ); has [qw/ordered/] => ( is => 'ro', isa => 'Bool' ); has [qw/warp help/] => ( is => 'rw', isa => 'Maybe[HashRef]' ); around BUILDARGS => sub { my $orig = shift; my $class = shift; my %args = @_; my %h = map { ( $_ => $args{$_} ); } grep { defined $args{$_} } @allowed_warp_params; return $class->$orig( backup => dclone( \%h ), @_ ); }; sub BUILD { my $self = shift; if ( defined $self->refer_to or defined $self->computed_refer_to ) { $self->submit_to_refer_to(); } $self->set_properties(); # set will use backup data if ( defined $self->warp ) { my $warp_info = $self->warp; $self->{warper} = Config::Model::Warper->new( warped_object => $self, %$warp_info, allowed => \@allowed_warp_params ); } $self->cl_init; $logger->info( "Created check_list element " . $self->element_name ); return $self; } sub cl_init { my $self = shift; $self->warp if ( $self->{warp} ); if ( defined $self->{ref_object} ) { my $level = $self->parent->get_element_property( element => $self->{element_name}, property => 'level', ); $self->{ref_object}->get_choice_from_refered_to if $level ne 'hidden'; } } sub name { my $self = shift; my $name = $self->{parent}->name . ' ' . $self->{element_name}; return $name; } sub value_type { return 'check_list'; } # warning : call to 'set' are not cumulative. Default value are always # restored. Lest keeping track of what was modified with 'set' is # too hard for the user. sub set_properties { my $self = shift; # cleanup all parameters that are handled by warp map( delete $self->{$_}, @allowed_warp_params ); if ( $logger->is_debug() ) { my %h = @_; my $keys = join( ',', keys %h ); $logger->debug("set_properties called on $self->{element_name} with $keys"); } # merge data passed to the constructor with data passed to set my %args = ( %{ $self->{backup} }, @_ ); # these are handled by Node or Warper map { delete $args{$_} } qw/level/; $self->{ordered} = delete $args{ordered} || 0; if ( defined $args{choice} ) { my @choice = @{ delete $args{choice} }; $self->{default_choice} = \@choice; $self->setup_choice(@choice); } if ( defined $args{default} ) { warn $self->name, ": default param is deprecated, use default_list\n"; $args{default_list} = delete $args{default}; } if ( defined $args{default_list} ) { $self->{default_list} = delete $args{default_list}; } # store default data in a hash (more convenient) $self->{default_data} = { map { $_ => 1 } @{ $self->{default_list} } }; if ( defined $args{upstream_default_list} ) { $self->{upstream_default_list} = delete $args{upstream_default_list}; } # store upstream default data in a hash (more convenient) $self->{upstream_default_data} = { map { $_ => 1 } @{ $self->{upstream_default_list} } }; Config::Model::Exception::Model->throw( object => $self, error => "Unexpected parameters :" . join( ' ', keys %args ) ) if scalar keys %args; if ( $self->has_warped_slaves ) { my $hash = $self->get_checked_list_as_hash; # force scalar context $self->trigger_warp($hash, $self->fetch); } } sub setup_choice { my $self = shift; my @choice = ref $_[0] ? @{ $_[0] } : @_; $logger->debug("CheckList $self->{element_name}: setup_choice with @choice"); # store all enum values in a hash. This way, checking # whether a value is present in the enum set is easier delete $self->{choice_hash} if defined $self->{choice_hash}; map { $self->{choice_hash}{$_} = 1; } @choice; $self->{choice} = \@choice; # cleanup current preset and data if it does not fit current choices foreach my $field (qw/preset data layered/) { next unless defined $self->{$field}; # do not create if not present foreach my $item ( keys %{ $self->{$field} } ) { delete $self->{$field}{$item} unless defined $self->{choice_hash}{$item}; } } } # Need to extract Config::Model::Reference (used by Value, and maybe AnyId). sub submit_to_refer_to { my $self = shift; if ( defined $self->refer_to ) { $self->{ref_object} = Config::Model::IdElementReference->new( refer_to => $self->refer_to, config_elt => $self, ); } elsif ( defined $self->computed_refer_to ) { $self->{ref_object} = Config::Model::IdElementReference->new( computed_refer_to => $self->computed_refer_to, config_elt => $self, ); my $var = $self->{computed_refer_to}{variables}; # refer_to registration is done for all element that are used as # variable for complex reference (ie '- $foo' , {foo => '- bar'} ) foreach my $path ( values %$var ) { # is ref during test case #print "path is '$path'\n"; next if $path =~ /\$/; # next if path also contain a variable my $master = $self->grab($path); next unless $master->can('register_dependency'); $master->register_dependency($self); } } else { croak "checklist submit_to_refer_to: undefined refer_to or computed_refer_to"; } } sub setup_reference_choice { my $self = shift; $self->setup_choice(@_); } sub get_type { my $self = shift; return 'check_list'; } sub get_cargo_type { goto &cargo_type } sub cargo_type { my $self = shift; return 'leaf'; } sub apply_fixes { # no operation. THere's no check_value method because a check list # supposed to be always correct. Hence apply_fixes is empty. } sub notify_change { my $self = shift; my %args = @_; return if $self->instance->initial_load and not $args{really}; $self->SUPER::notify_change( %args, value_type => $self->value_type ); # notify all warped or computed objects that depends on me foreach my $s ( $self->get_warped_slaves ) { $logger->debug( "calling notify_change on slave ", $s->name ) if $logger->is_debug; $s->notify_change( note => 'checklist master triggered changed' ); } } # does not check the validity, but check the item of the check_list sub check { my $self = shift; my @list = ref $_[0] eq 'ARRAY' ? @{ $_[0] } : @_; my %args = ref $_[0] eq 'ARRAY' ? @_[ 1, $#_ ] : ( check => 'yes' ); my $check = $self->_check_check( $args{check} ); if ( defined $self->{ref_object} ) { $self->{ref_object}->get_choice_from_refered_to; } my @changed; map { push @changed, $_ if $self->store( $_, 1, $check ) } @list; $self->notify_change( note => "check @changed" ) unless $self->instance->initial_load; } sub clear_item { my $self = shift; my $choice = shift; my $inst = $self->instance; my $data_name = $inst->preset ? 'preset' : $inst->layered ? 'layered' : 'data'; my $old_v = $self->{$data_name}{$choice}; my $changed = 0; if ($old_v) { $changed = 1; } delete $self->{$data_name}{$choice}; if ( $self->{ordered} and $changed ) { my $ord = $self->{ordered_data}; my @new = grep { $_ ne $choice } @$ord; $self->{ordered_data} = \@new; } return $changed; } # internal sub store { my ( $self, $choice, $value, $check ) = @_; my $inst = $self->instance; if ( $value != 0 and $value != 1 ) { Config::Model::Exception::WrongValue->throw( error => "store: check item value must be boolean, " . "not '$value'.", object => $self ); return; } my $ok = $self->{choice_hash}{$choice} || 0; my $changed = 0; if ($ok) { my $data_name = $inst->preset ? 'preset' : $inst->layered ? 'layered' : 'data'; my $old_v = $self->{$data_name}{$choice}; if ( not defined $old_v or $old_v ne $value ) { $changed = 1; $self->{$data_name}{$choice} = $value; } if ( $self->{ordered} and $value ) { my $ord = $self->{ordered_data}; push @$ord, $choice unless scalar grep { $choice eq $_ } @$ord; } } elsif ( $check eq 'yes' ) { my $err_str = "Unknown check_list item '$choice'. Expected '" . join( "', '", @{ $self->{choice} } ) . "'"; $err_str .= "\n\t" . $self->{ref_object}->reference_info if defined $self->{ref_object}; Config::Model::Exception::WrongValue->throw( error => $err_str, object => $self ); } if ( $ok and $changed and $self->has_warped_slaves and not( $self->instance->layered or $self->instance->preset ) ) { my $h = $self->get_checked_list_as_hash; my $str = $self->fetch; $self->trigger_warp($h , $str); } return $changed; } sub uncheck { my $self = shift; my @list = ref $_[0] eq 'ARRAY' ? @{ $_[0] } : @_; my %args = ref $_[0] eq 'ARRAY' ? @_[ 1, $#_ ] : ( check => 'yes' ); my $check = $self->_check_check( $args{check} ); if ( defined $self->{ref_object} ) { $self->{ref_object}->get_choice_from_refered_to; } my @changed; map { push @changed, $_ if $self->store( $_, 0, $check ) } @list; $self->notify_change( note => "uncheck @changed" ) unless $self->instance->initial_load; } 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 user/; sub is_checked { my $self = shift; my $choice = shift; my %args = @_; my $mode = $args{mode} || ''; my $check = $self->_check_check( $args{check} ); my $ok = $self->{choice_hash}{$choice} || 0; if ($ok) { if ( $mode and not defined $accept_mode{$mode} ) { croak "is_checked: expected ", join( ' or ', keys %accept_mode ), "parameter, not $mode"; } my $dat = $self->{data}{$choice}; my $pre = $self->{preset}{$choice}; my $def = $self->{default_data}{$choice}; my $ud = $self->{upstream_default_data}{$choice}; my $lay = $self->{layered}{$choice}; my $std_v = $pre // $def // 0; my $user_v = $dat // $pre // $lay // $def // $ud // 0; my $result = $mode eq 'custom' ? ( $dat && !$std_v ? 1 : 0 ) : $mode eq 'preset' ? $pre : $mode eq 'layered' ? $lay : $mode eq 'upstream_default' ? $ud : $mode eq 'default' ? $def : $mode eq 'standard' ? $std_v : $mode eq 'user' ? $user_v : $dat // $std_v; return $result; } elsif ( $check eq 'yes' ) { my $err_str = "Unknown check_list item '$choice'. Expected '" . join( "', '", @{ $self->{choice} } ) . "'"; $err_str .= "\n\t" . $self->{ref_object}->reference_info if defined $self->{ref_object}; Config::Model::Exception::WrongValue->throw( error => $err_str, object => $self ); } } # get_choice is always called when using check_list, so having a # warp safety check here makes sense sub get_choice { my $self = shift; if ( defined $self->{ref_object} ) { $self->{ref_object}->get_choice_from_refered_to; } if ( not defined $self->{choice} ) { my $msg = "check_list element has no defined choice. " . $self->warp_error; Config::Model::Exception::UnavailableElement->throw( info => $msg, object => $self->parent, element => $self->element_name, ); } return @{ $self->{choice} }; } sub get_default_choice { my $self = shift; return @{ $self->{default_choice} || [] }; } sub get_builtin_choice { carp "get_builtin_choice is deprecated, use get_upstream_default_choice"; goto &get_upstream_default_choice; } sub get_upstream_default_choice { my $self = shift; return @{ $self->{upstream_default_data} || [] }; } sub get_help { my $self = shift; my $help = $self->{help}; return $help unless @_; my $on_value = shift; return $help->{$on_value} if defined $help and defined $on_value; return; } sub clear { my $self = shift; map { $self->clear_item($_) } $self->get_choice; # also triggers notify changes } sub clear_values { goto &clear; } sub clear_layered { my $self = shift; $self->{layered} = {}; } my %old_mode = ( built_in_list => 'upstream_default_list', ); sub get_checked_list_as_hash { my $self = shift; my %args = @_ > 1 ? @_ : ( mode => $_[0] ); my $mode = $args{mode} || ''; foreach my $k ( keys %old_mode ) { next unless $mode eq $k; $mode = $old_mode{$k}; carp $self->location, " warning: deprecated mode parameter: $k, ", "expected $mode\n"; } if ( $mode and not defined $accept_mode{$mode} ) { croak "get_checked_list_as_hash: expected ", join( ' or ', keys %accept_mode ), " parameter, not $mode"; } my $dat = $self->{data}; my $pre = $self->{preset}; my $def = $self->{default_data}; my $lay = $self->{layered}; my $ud = $self->{upstream_default_data}; # fill empty hash result my %h = map { $_ => 0 } $self->get_choice; my %predef = ( %$def, %$pre ); my %std = ( %$ud, %$lay, %$def, %$pre ); # use _std_backup if all data values are null (no checked items by user) my %old_dat = ( none { $_; } values %$dat ) ? %{ $self->{_std_backup} || {} } : %$dat; if ( not $mode and any { $_; } values %predef and none { $_; } values %old_dat ) { # changed from nothing to default checked list that must be written $self->{_std_backup} = { %$def, %$pre }; $self->notify_change( note => "use default checklist" ); } # custom test must compare the whole list at once, not just one item at a time. my %result = $mode eq 'custom' ? ( ( grep { $dat->{$_} xor $std{$_} } keys %h ) ? ( %$pre, %$dat ) : () ) : $mode eq 'preset' ? (%$pre) : $mode eq 'layered' ? (%$lay) : $mode eq 'upstream_default' ? (%$ud) : $mode eq 'default' ? (%$def) : $mode eq 'standard' ? %std : $mode eq 'user' ? ( %h, %std, %$dat ) : ( %predef, %$dat ); return wantarray ? %result : \%result; } sub get_checked_list { my $self = shift; my %h = $self->get_checked_list_as_hash(@_); my @good_order = $self->{ordered} ? @{ $self->{ordered_data} } : sort keys %h; my @res = grep { $h{$_} } @good_order; return wantarray ? @res : \@res; } sub fetch { my $self = shift; return join( ',', $self->get_checked_list(@_) ); } sub fetch_custom { my $self = shift; return join( ',', $self->get_checked_list('custom') ); } sub fetch_preset { my $self = shift; return join( ',', $self->get_checked_list('preset') ); } sub fetch_layered { my $self = shift; return join( ',', $self->get_checked_list('layered') ); } sub get { my $self = shift; my $path = shift; if ($path) { Config::Model::Exception::User->throw( object => $self, message => "get() called with a value with non-empty path: '$path'" ); } return $self->fetch(@_); } sub set { my $self = shift; my $path = shift; my $list = shift; if ($path) { Config::Model::Exception::User->throw( object => $self, message => "set() called with a value with non-empty path: '$path'" ); } return $self->set_checked_list( split /,/, $list ); } sub load { my ( $self, $string ) = @_; my @set = split /,/, $string; foreach (@set) { s/^"|"$//g; s/\\"/"/g; } $self->set_checked_list(@set); } sub store_set { goto &set_checked_list } sub set_checked_list { my $self = shift; $logger->debug("called with @_"); my %set = map { $_ => 1 } @_; my @changed; foreach my $c ( $self->get_choice ) { push @changed, $c if $self->store( $c, $set{$c} // 0 ); } $self->{ordered_data} = [@_]; # copy list $self->notify_change( note => "set_checked_list @changed" ) if @changed and not $self->instance->initial_load; } sub set_checked_list_as_hash { my $self = shift; my %check = ref $_[0] ? %{ $_[0] } : @_; foreach my $c ( $self->get_choice ) { if ( defined $check{$c} ) { $self->store( $c, $check{$c} ); } else { $self->clear_item($c); } } } sub load_data { my $self = shift; my %args = @_ > 1 ? @_ : ( data => shift ); my $data = $args{data}; my $check = $self->_check_check( $args{check} ); if ( ref($data) eq 'ARRAY' ) { $self->set_checked_list(@$data); } elsif ( ref($data) eq 'HASH' ) { $self->set_checked_list_as_hash($data); } elsif ( not ref($data) ) { $self->set_checked_list($data); } else { Config::Model::Exception::LoadData->throw( object => $self, message => "check_list load_data called with unexpected type. ". "Expected plain scalar, array or hash ref", wrong_data => $data, ); } } sub swap { my ( $self, $a, $b ) = @_; foreach my $param ( $a, $b ) { unless ( $self->is_checked($param) ) { my $err_str = "swap: choice $param must be set"; Config::Model::Exception::WrongValue->throw( error => $err_str, object => $self ); } } # perform swap in ordered list foreach ( @{ $self->{ordered_data} } ) { if ( $_ eq $a ) { $_ = $b; } elsif ( $_ eq $b ) { $_ = $a; } } } sub move_up { my ( $self, $c ) = @_; unless ( $self->is_checked($c) ) { my $err_str = "swap: choice $c must be set"; Config::Model::Exception::WrongValue->throw( error => $err_str, object => $self ); } # perform move in ordered list my $list = $self->{ordered_data}; for ( my $i = 1 ; $i < @$list ; $i++ ) { if ( $list->[$i] eq $c ) { $list->[$i] = $list->[ $i - 1 ]; $list->[ $i - 1 ] = $c; last; } } } sub move_down { my ( $self, $c ) = @_; unless ( $self->is_checked($c) ) { my $err_str = "swap: choice $c must be set"; Config::Model::Exception::WrongValue->throw( error => $err_str, object => $self ); } # perform move in ordered list my $list = $self->{ordered_data}; for ( my $i = 0 ; $i + 1 < @$list ; $i++ ) { if ( $list->[$i] eq $c ) { $list->[$i] = $list->[ $i + 1 ]; $list->[ $i + 1 ] = $c; last; } } } # dummy to match Value call sub warning_msg { '' } 1; # ABSTRACT: Handle check list element __END__ =pod =encoding UTF-8 =head1 NAME Config::Model::CheckList - Handle check list element =head1 VERSION version 2.097 =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 simple check list with help: choice_list => { type => 'check_list', choice => ['A' .. 'Z'], help => { A => 'A help', E => 'E help' } , }, =item * A check list with default values: choice_list_with_default => { type => 'check_list', choice => ['A' .. 'Z'], default_list => [ 'A', 'D' ], }, =item * A check list whose available choice and default change depending on the value of the C parameter: 'warped_choice_list' => { type => 'check_list', warp => { follow => '- macro', rules => { AD => { choice => [ 'A' .. 'D' ], default_list => ['A', 'B' ] }, AH => { choice => [ 'A' .. 'H' ] }, } } }, =back =head1 Introspection methods The following methods returns the checklist parameter : =over =item refer_to =item computed_refer_to =back =head1 Choice reference The choice items of a check_list can be given by another configuration element. This other element can be: =over =item * The keys of a hash =item * Another checklist. In this case only the checked items of the other checklist 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( 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 (choice_value) Return the help string on this choice value =head2 clear Reset the check list (can also be called as C) =head2 clear_item (choice_value) Reset an element of the checklist. =head2 get_checked_list_as_hash ( [ custom | preset | standard | default ] ) Returns a hash (or a hash ref) of all items. The boolean value is the value of the hash. Example: { A => 0, B => 1, C => 0 , D => 1} By default, this method returns all items set by the user, or items set in preset mode or checked by default. With a parameter, this method returns either: =over =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) =back =head2 get_checked_list ( < mode > ) Returns a list (or a list ref) of all checked items (i.e. all items set to 1). =head2 fetch ( < mode > ) Returns a string listing the checked items (i.e. "A,B,C") =head2 get( path [, < mode> ] ) Get a value from a directory like path. =head2 set( path , values ) Set a checklist with a directory like path. Since a checklist is a leaf, the path should be empty. The values are a comma separated list of checked items. Example : C<< $leaf->set('','A,C,Z') ; >> =head2 set_checked_list ( item1, item2, ..) Set all passed items to checked (1). All other available items in the check list are set to 0. Example: # set cl to A=0 B=1 C=0 D=1 $cl->set_checked_list('B','D') =head2 set_checked_list_as_hash () Set check_list items. Missing items in the given list of parameters are cleared (i.e. set to undef). =head2 load_data ( ref ) Load check_list as an array or hash ref. Array is forwarded to L , and hash is forwarded to L. =head1 Ordered checklist methods All the methods below are valid only for ordered checklists. =head1 swap ( choice_a, choice_b) Swap the 2 given choice in the list. Both choice must be already set. =head1 move_up ( choice ) Move the choice up in the checklist. =head1 move_down ( choice ) Move the choice down in the checklist. =head1 AUTHOR Dominique Dumont, (ddumont at cpan dot org) =head1 SEE ALSO L, L, L, L, L, L, L =head1 AUTHOR Dominique Dumont =head1 COPYRIGHT AND LICENSE This software is Copyright (c) 2005-2016 by Dominique Dumont. This is free software, licensed under: The GNU Lesser General Public License, Version 2.1, February 1999 =cut Config-Model-2.097/lib/Config/Model/ValueComputer.pm0000644000175000017500000007363213027007223020613 0ustar domidomi# # This file is part of Config-Model # # This software is Copyright (c) 2005-2016 by Dominique Dumont. # # This is free software, licensed under: # # The GNU Lesser General Public License, Version 2.1, February 1999 # package Config::Model::ValueComputer; $Config::Model::ValueComputer::VERSION = '2.097'; use Mouse; use MouseX::StrictConstructor; # use Scalar::Util qw(weaken) ; use Carp; use Parse::RecDescent 1.90.0; use Data::Dumper (); use Log::Log4perl qw(get_logger :levels); use vars qw($compute_grammar $compute_parser); my $logger = get_logger("ValueComputer"); # allow_override is intercepted and handled by Value object has formula => ( is => 'ro', isa => 'Str', required => 1 ); has value_type => ( is => 'ro', isa => 'Str', required => 1 ); # value_object is mostly used for error messages has value_object => ( is => 'ro', isa => 'Config::Model::AnyThing', required => 1, weak_ref => 1 ); has variables => ( is => 'ro', isa => 'HashRef', default => sub { {} } ); has replace => ( is => 'ro', isa => 'HashRef', default => sub { {} } ); has [qw/use_eval allow_override use_as_upstream_default/] => ( is => 'ro', isa => 'Bool', default => 0 ); has allow_user_override => ( is => 'ro', isa => 'Bool', lazy => 1, builder => sub { my $self = shift; return $self->allow_override || $self->use_as_upstream_default; } ); has need_quote => ( is => 'ro', isa => 'Bool', builder => '_need_quote', lazy => 1 ); sub _need_quote { my $self = shift; my $need_quote = 0; $need_quote = 1 if $self->{use_eval} and $self->{value_type} !~ /(integer|number|boolean)/; return $need_quote; } has undef_is => ( is => 'ro', isa => 'Maybe[Str]' ); has undef_replacement => ( is => 'ro', isa => 'Maybe[Str]', builder => '_build_undef_replacement', lazy => 1 ); sub _build_undef_replacement { my $self = shift; my $sui = $self->undef_is; my $need_quote = $self->need_quote; return $need_quote && defined $sui && $sui eq "''" ? "''" : $need_quote && defined $sui ? "'$sui'" : defined $sui && $sui eq "''" ? '' : defined $sui ? $sui : undef; } sub BUILD { my $self = shift; # create parser if needed $compute_parser ||= Parse::RecDescent->new($compute_grammar); $logger->debug("called with formula: $self->{formula}"); # must make a first pass at computation to subsitute index and # element values. leaves $xxx outside of &index or &element untouched my $result_r = $compute_parser->pre_compute( $self->{formula}, 1, $self->{value_object}, $self->{variables}, $self->{replace}, 'yes', $self->need_quote, ); $logger->debug("pre_formula: $$result_r"); $self->{pre_formula} = $$result_r; } sub compute { my $self = shift; my %args = @_; my $check = $args{check} || 'yes'; my $pre_formula = $self->{pre_formula}; $logger->debug("called with pre_formula: $pre_formula"); my $variables = $self->compute_variables( check => $check ); die "internal error" unless defined $variables; my $result; my @parser_args = ( $self->{value_object}, $variables, $self->{replace}, $check, $self->{need_quote}, $self->undef_replacement ); if ( $self->{use_eval} or $self->{value_type} =~ /(integer|number|boolean)/ ) { $logger->debug("will use eval"); my $all_defined = 1; my @init; foreach my $key ( sort keys %$variables ) { # no need to get variable if not used in formula; next unless index( $pre_formula, $key ) > 0; my $vr = _value_from_object( $key, @parser_args ); my $v = $$vr; $v = $self->undef_replacement unless defined $v; $logger->debug( "compute: var $key -> ", ( defined $v ? $v : '' ) ); if ( defined $v ) { push @init, "my \$$key = $v ;\n"; } else { $all_defined = 0; } } if ($all_defined) { my $formula = join( '', @init ) . $pre_formula; $logger->debug("compute: evaluating '$formula'"); $result = eval $formula; if ($@) { Config::Model::Exception::Formula->throw( object => $self->{value_object}, error => "Eval of formula '$formula' failed:\n$@" . "Make sure that your element is indeed " . "'$self->{value_type}'" ); } } } else { $logger->debug("calling parser with compute on pre_formula $pre_formula"); my $formula_r = $compute_parser->compute( $pre_formula, 1, @parser_args ); $result = $$formula_r; #$result = $self->{computed_formula} = $formula; } $logger->debug( "compute result is '" . ( defined $result ? $result : '' ) . "'" ); return $result; } sub compute_info { my $self = shift; my %args = @_; my $check = $args{check} || 'yes'; $logger->debug("compute_info called with $self->{formula}"); my $orig_variables = $self->{variables}; my $variables = $self->compute_variables; my $str = "value is computed from '$self->{formula}'"; return $str unless defined $variables; #print Dumper $variables ; if (%$variables) { $str .= ", where "; foreach my $k ( sort keys %$variables ) { my $u_val = $variables->{$k}; if ( ref($u_val) ) { map { $str .= "\n\t\t'\$$k" . "{$_} is converted to '$orig_variables->{$k}{$_}'"; } sort keys %$u_val; } else { my $val; if ( defined $u_val ) { my $obj = eval { $self->{value_object}->grab($u_val) }; if ($@) { my $e = $@; my $msg = ref($e) ? $e->full_message : $e; Config::Model::Exception::Model->throw( object => $self, error => "Compute variable:\n" . $msg ); } $val = $obj->get_type eq 'node' ? '' : $obj->get_type eq 'hash' ? '' : $obj->get_type eq 'list' ? '' : $obj->fetch( check => $check ); } $str .= "\n\t\t'$k' from path '$orig_variables->{$k}' is "; $str .= defined $val ? "'$val'" : 'undef'; } } } #$str .= " (evaluated as '$self->{computed_formula}')" # if $self->{formula} ne $self->{computed_formula} ; return $str; } # internal. resolves variables that contains $foo or &bar # returns a hash of variable names -> variable path sub compute_variables { my $self = shift; my %args = @_; my $check = $args{check} || 'yes'; # a shallow copy should be enough as we don't allow # replace in replacement rules my %variables = %{ $self->{variables} }; $logger->debug( "called on variables '", join( "', '", sort keys %variables ), "'" ) if $logger->is_debug; # apply a compute on all variables until no $var is left my $var_left = scalar( keys %variables ) + 1; while ($var_left) { my $old_var_left = $var_left; foreach my $key ( keys %variables ) { my $value = $variables{$key}; # value may be undef next unless defined $value; #next if ref($value); # skip replacement rules $logger->debug("key '$key', value '$value', left $var_left"); next unless $value =~ /\$|&/; my $pre_res_r = $compute_parser->pre_compute( $value, 1, $self->{value_object}, \%variables, $self->{replace}, $check ); $logger->debug("key '$key', pre res '$$pre_res_r', left $var_left\n"); $variables{$key} = $$pre_res_r; $logger->debug( "variable after pre_compute: ", join( " ", keys %variables ) ) if $logger->is_debug; if ( $$pre_res_r =~ /\$/ ) { ; # variables needs to be evaluated my $res_ref = $compute_parser->compute( $$pre_res_r, 1, $self->{value_object}, \%variables, $self->{replace}, $check ); #return undef unless defined $res ; $variables{$key} = $$res_ref; $logger->debug( "variable after compute: ", join( " ", keys %variables ) ) if $logger->is_debug; } { no warnings "uninitialized"; $logger->debug("result $key -> '$variables{$key}' left '$var_left'"); } } my @var_left = grep { defined $variables{$_} && $variables{$_} =~ /[\$&]/ } sort keys %variables; $var_left = @var_left; Config::Model::Exception::Formula->throw( object => $self->{value_object}, error => "Can't resolve user variable: '" . join( "','", @var_left ) . "'" ) unless ( $var_left < $old_var_left ); } $logger->debug("done"); return \%variables; } sub _pre_replace { my ( $replace_h, $pre_value ) = @_; $logger->debug("value: _pre_replace called with value '$pre_value'"); my $result = exists $replace_h->{$pre_value} ? $replace_h->{$pre_value} : '$replace{' . $pre_value . '}'; return \$result; } sub _replace { my ( $replace_h, $value, $value_object, $variables, $replace, $check, $need_quote, $undef_is ) = @_; if ( $logger->is_debug ) { my $str = defined $value ? $value : ''; $logger->debug("value: _replace called with value '$str'"); } my $result; if ( defined $value and $value =~ /\$/ ) { # must keep original variable $result = '$replace{' . $value . '}'; } elsif ( defined $value ) { my $r = $replace_h->{$value}; $result = defined $r ? $r : $undef_is; } return \$result; } sub _function_on_object { my ( $up, $function, $return, $value_object, $variables_h, $replace_h, $check, $need_quote ) = @_; $logger->debug("handling &$function($up) "); # get now the object refered $up =~ s/-(\d+)/'- ' x $1/e; my $target = eval { $value_object->grab( step => $up, check => $check ) }; if ($@) { my $e = $@; my $msg = $e ? $e->full_message : ''; Config::Model::Exception::Model->throw( object => $value_object, error => "Compute function argument '$up':\n" . $msg ); } if ( $function eq 'element' ) { my $result = $target->element_name; Config::Model::Exception::Model->throw( object => $value_object, error => "'", $target->name, "' has no element name" ) unless defined $result; $return = \$result; } elsif ( $function eq 'index' ) { my $result = $target->index_value; Config::Model::Exception::Formula->throw( object => $value_object, error => "'", $target->name, "' has no index value" ) unless defined $result; $return = \$result; } else { Config::Model::Exception::Formula->throw( object => $value_object, error => "Unknown computation function &$function, " . "expected &element(...) or &index(...)" ); } # print "\&foo(...) result = ",$$return," \n"; # make sure that result of function is quoted (avoid bareword errors) $$return = '"' . $$return . '"' if $need_quote; $logger->debug("&$function(...) returns $$return"); return $return; } sub _function_alone { my ( $f_name, $return, $value_object, $variables_h, $replace_h, $check, $need_quote ) = @_; $logger->debug("_function_alone: handling $f_name"); my $method_name = $f_name eq 'element' ? 'element_name' : $f_name eq 'index' ? 'index_value' : $f_name eq 'location' ? 'location' : undef; Config::Model::Exception::Formula->throw( object => $value_object, error => "Unknown computation function &$f_name, " . "expected &element or &index" ) unless defined $method_name; my $result = $value_object->$method_name(); my $vt = $value_object->value_type; if ( $vt =~ /^integer|number|boolean$/ ) { $result = '"' . $result . '"'; } $return = \$result; Config::Model::Exception::Formula->throw( object => $value_object, error => "Missing $f_name attribute (method '$method_name' on " . ref($value_object) . ")\n" ) unless defined $result; return $return; } sub _compute { my ( $value_ref, $return, $value_object, $variables_h, $replace_h, $check, $need_quote, $undef_is ) = @_; my @values = map { $$_ } @{$value_ref}; if ( $logger->is_debug ) { my @display = map { defined $_ ? $_ : '' } @values; $logger->debug( "_compute called with values '", join( "','", @display ) ); } my $result = ''; # return undef if one value is undef foreach my $v (@values) { if ( defined $v or defined $undef_is ) { $result .= defined $v ? $v : $undef_is; } else { $result = undef; last; } } return \$result; } sub _value_from_object { my ( $name, $value_object, $variables_h, $replace_h, $check, $need_quote ) = @_; $logger->warn("Warning: No variable definition found for \$$name") unless exists $variables_h->{$name}; # $path can be a ref for test purpose, or can be undef if path is computed from another value my $path = $variables_h->{$name}; my $my_res; if ( $logger->is_debug ) { my $str = defined $path ? $path : ''; $logger->debug("replace \$$name with path $str..."); } if ( defined $path and $path =~ /[\$&]/ ) { $logger->trace("skip name $name path '$path'"); $my_res = "\$$name"; # restore name that contain '$var' } elsif ( defined $path ) { $logger->trace("fetching var object '$name' with '$path'"); $my_res = eval { $value_object->grab_value( step => $path, check => $check ); }; if ($@) { my $e = $@; my $msg = $e ? $e->full_message : ''; Config::Model::Exception::Model->throw( object => $value_object, error => "Compute argument '$name', error with '$path':\n" . $msg ); } $logger->trace( "fetched var object '$name' with '$path', result '", defined $my_res ? $my_res : 'undef', "'" ); } # my_res stays undef if $path if not defined # quote result if asked when calling compute my $quote = $need_quote || 0; if ($quote && $my_res) { $my_res =~ s/'/\\'/g; $my_res = "'$my_res'"; } return \$my_res; # So I can return undef ... or a ref to undef } $compute_grammar = << 'END_OF_GRAMMAR' ; { # This grammar is compatible with Parse::RecDescent < 1.90 or >= 1.90 use strict; use warnings ; } # computed value may return undef even if parsing is done right. To # avoid getting problems with Parse::RecDescent (where undef means # that the parsing did not match), we 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.097 =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)>. =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. =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 => { value_type => 'string', mandatory => 1, migrate_from => { use_eval => 1, formula => '$old || $older ;', undef_is => "''", variables => { older => '- Original-Source-Location', old => '- Upstream-Source' } }, type => 'leaf', }, [qw/Upstream-Source Original-Source-Location/] => { value_type => 'string', status => 'deprecated', type => 'leaf' } =head1 Examples =head2 String substitution [qw/sav sbv/] => { type => 'leaf', value_type => 'string', }, compute_string => { type => 'leaf', value_type => 'string', compute => { formula => 'meet $a and $b', variables => { '- sav', b => '- sbv' } }, }, =head2 Computation with on-the-fly replacement compute_with_replace => { type => 'leaf', value_type => 'string', compute => { formula => '$replace{$who} is the $replace{$what} of $replace{$country}', variables => { who => '! who', what => '! what', country => '- country', }, replace => { chief => 'president', America => 'USA' }, }, }, =head2 Extract data from a value using a Perl regexp Extract the host name from an URL: url => { type => 'leaf', value_type => 'uniline' }, extract_host_from_url => { type => 'leaf', value_type => 'uniline', compute => { formula => '$old =~ m!http://([\w\.]+)!; $1 ;', variables => { old => '- url' }, use_eval => 1, }, }, =head2 simple copy hash example Copying a hash may not be useful, but the using C<&index()> in a variable can be. Here's an example where the hashes contain leaves. The model is set up so that the content of C is copied into C hash: copy_from => { 'type' => 'hash', 'index_type' => 'string', 'cargo' => { 'config_class_name' => 'From', 'type' => 'node' }, }, copy_to => { 'type' => 'hash', 'index_type' => 'string', 'cargo' => { 'type' => 'leaf', 'value_type' => 'uniline', 'compute' => { 'formula' => '$copied', 'variables' => { 'copied' => '- copy_from:&index()' } }, }, }, Hash copy is also possible when the hash contains node. Here's an example where the data to be copied is stored within a node. The main class has 2 hash elements: copy_from => { 'type' => 'hash', 'index_type' => 'string', 'cargo' => { 'config_class_name' => 'From', 'type' => 'node' }, }, copy_to => { 'type' => 'hash', 'index_type' => 'string', 'cargo' => { 'config_class_name' => 'To', 'type' => 'node' }, }, The Class to copy from is quite simple: 'name' => 'From', 'element' => [ name => { 'type' => 'leaf', 'value_type' => 'uniline', } ] Here the class to copy to: 'name' => 'To', 'element' => [ name => { 'type' => 'leaf', 'value_type' => 'uniline', 'compute' => { 'formula' => '$copied', 'variables' => { 'copied' => '! copy_from:&index(-) name' } }, } ] =head1 AUTHOR Dominique Dumont, (ddumont at cpan dot org) =head1 SEE ALSO L, L, L =head1 AUTHOR Dominique Dumont =head1 COPYRIGHT AND LICENSE This software is Copyright (c) 2005-2016 by Dominique Dumont. This is free software, licensed under: The GNU Lesser General Public License, Version 2.1, February 1999 =cut Config-Model-2.097/lib/Config/Model/Node.pm0000644000175000017500000015325113027007223016701 0ustar domidomi# # This file is part of Config-Model # # This software is Copyright (c) 2005-2016 by Dominique Dumont. # # This is free software, licensed under: # # The GNU Lesser General Public License, Version 2.1, February 1999 # package Config::Model::Node; $Config::Model::Node::VERSION = '2.097'; use Mouse; with "Config::Model::Role::NodeLoader"; use Carp; use 5.010; use Config::Model::Exception; use Config::Model::Loader; use Config::Model::Dumper; use Config::Model::DumpAsData; use Config::Model::Report; use Config::Model::TreeSearcher; use Config::Model::Describe; use Config::Model::BackendMgr; use Log::Log4perl qw(get_logger :levels); use Storable qw/dclone/; use List::MoreUtils qw(insert_after_string); extends qw/Config::Model::AnyThing/; with "Config::Model::Role::Grab"; with "Config::Model::Role::HelpAsText"; use vars qw(@status @level %default_property); *status = *Config::Model::status; *level = *Config::Model::level; *default_property = *Config::Model::default_property; my %legal_properties = ( status => {qw/obsolete 1 deprecated 1 standard 1/}, level => {qw/important 1 normal 1 hidden 1/}, ); my $logger = get_logger("Tree::Node"); my $fix_logger = get_logger("Anything::Fix"); my $change_logger = get_logger("ChangeTracker"); my $deep_check_logger = get_logger('DeepCheck'); # Here are the legal element types my %create_sub_for = ( node => \&create_node, leaf => \&create_leaf, hash => \&create_id, list => \&create_id, check_list => \&create_id, warped_node => \&create_warped_node, ); # Node internal documentation # # Since the class holds a significant number of element, here's its # main structure. # # $self # = ( # config_model : Weak reference to Config::Model object # config_class_name # model : model of the config class # instance : Weak reference to Config::Model::Instance object # element_name : Name of the element containing this node # (undef for root node). # parent : weak reference of parent node (undef for root node) # element : actual storage of configuration elements # ) ; has initialized => ( is => 'rw', isa => 'Bool', default => 0 ); has config_class_name => ( is => 'ro', isa => 'Str', required => 1 ); has [qw/config_file element_name/] => ( is => 'ro', isa => 'Maybe[Str]', required => 0 ); has instance => ( is => 'ro', isa => 'Config::Model::Instance', weak_ref => 1, required => 1 ); has config_model => ( is => 'ro', isa => 'Config::Model', weak_ref => 1, lazy => 1, builder => '_config_model' ); sub _config_model { my $self = shift; my $p = $self->instance->config_model; } has check => ( is => 'ro', isa => 'Str', default => 'yes' ); has model => ( is => 'rw', isa => 'HashRef' ); has needs_save => ( is => 'rw', isa => 'Bool', default => 0 ); has backend_mgr => ( is => 'ro', isa => 'Maybe[Config::Model::BackendMgr]' ); # attribute is defined in Config::Model::Anythin sub _backend_support_annotation { my $self = shift; return $self->backend_mgr ? $self->backend_mgr->support_annotation : $self->parent ? $self->parent->backend_support_annotation : undef ; # no backend at all. test only } sub BUILD { my $self = shift; my $read_check = $self->instance->read_check; my $req_check = $self->check; my $check = $req_check eq 'no' || $read_check eq 'no' ? 'no' : $req_check eq 'skip' || $read_check eq 'skip' ? 'skip' : 'yes'; my $caller_class = defined $self->parent ? $self->parent->name : 'user'; my $class_name = $self->config_class_name; $logger->info("New $class_name requested by $caller_class"); # get_model returns a cloned data structure $self->model( $self->config_model->get_model($class_name) ); $self->{original_model} = dclone($self->model); $self->check_properties; return $self; } ## Create_* methods are all internal and should not be used directly sub create_element { my $self = shift; my %args = @_ > 1 ? @_ : ( name => shift ); my $element_name = $args{name}; my $check = $args{check} || 'yes'; my $element_info = $self->{model}{element}{$element_name}; if ( not defined $element_info ) { if ( $check eq 'yes' ) { Config::Model::Exception::UnknownElement->throw( object => $self, function => 'create_element', where => $self->location || 'configuration root', element => $element_name, ); } else { return; # just skip when check is no or skip } } Config::Model::Exception::Model->throw( error => "element '$element_name' error: " . "passed information is not a hash ref", object => $self ) unless ref($element_info) eq 'HASH'; Config::Model::Exception::Model->throw( error => "create element '$element_name' error: " . "missing 'type' parameter", object => $self ) unless defined $element_info->{type}; my $method = $create_sub_for{ $element_info->{type} }; croak $self->{config_class_name}, " error: unknown element type $element_info->{type}, expected ", join(' ', sort keys %create_sub_for) unless defined $method; $self->$method( $element_name, $check ); } sub create_node { my ( $self, $element_name, $check ) = @_; my $element_info = dclone( $self->{model}{element}{$element_name} ); my $config_class_name = $element_info->{config_class_name}; Config::Model::Exception::Model->throw( error => "create node '$element_name' error: " . "missing config class name parameter", object => $self ) unless defined $element_info->{config_class_name}; my @args = ( config_class_name => $config_class_name, instance => $self->{instance}, element_name => $element_name, check => $check, parent => $self, container => $self, ); $self->{element}{$element_name} = $self->load_node(@args); } sub create_warped_node { my ( $self, $element_name, $check ) = @_; my $element_info = dclone( $self->{model}{element}{$element_name} ); my @args = ( instance => $self->{instance}, element_name => $element_name, parent => $self, check => $check, container => $self, ); require Config::Model::WarpedNode; $self->{element}{$element_name} = Config::Model::WarpedNode->new( %$element_info, @args ); } sub create_leaf { my ( $self, $element_name, $check ) = @_; my $element_info = dclone( $self->{model}{element}{$element_name} ); delete $element_info->{type}; my $leaf_class = delete $element_info->{class} || 'Config::Model::Value'; if ( not defined *{ $leaf_class . '::' } ) { my $file = $leaf_class . '.pm'; $file =~ s!::!/!g; require $file; } $element_info->{container} = $element_info->{parent} = $self; $element_info->{element_name} = $element_name; $element_info->{instance} = $self->{instance}; $self->{element}{$element_name} = $leaf_class->new(%$element_info); } my %id_class_hash = ( hash => 'HashId', list => 'ListId', check_list => 'CheckList', ); sub create_id { my ( $self, $element_name, $check ) = @_; my $element_info = dclone( $self->{model}{element}{$element_name} ); my $type = delete $element_info->{type}; Config::Model::Exception::Model->throw( error => "create $type element '$element_name' error" . ": missing 'type' parameter", object => $self ) unless defined $type; croak "Undefined id_class for type '$type'" unless defined $id_class_hash{$type}; my $id_class = delete $element_info->{class} || 'Config::Model::' . $id_class_hash{$type}; if ( not defined *{ $id_class . '::' } ) { my $file = $id_class . '.pm'; $file =~ s!::!/!g; require $file; } $element_info->{container} = $element_info->{parent} = $self; $element_info->{element_name} = $element_name; $element_info->{instance} = $self->{instance}; $self->{element}{$element_name} = $id_class->new(%$element_info); } # check validity of level and status declaration. sub check_properties { my $self = shift; # a model should no longer contain attributes attached to # an element (like description, level ...). There are copied here # because Node needs them as hash or lists foreach my $bad (qw/description summary level status/) { die $self->config_class_name, ": illegal '$bad' parameter in model ", "(Should be handled by Config::Model directly)" if defined $self->{model}{$bad}; } foreach my $elt_name ( @{ $self->{model}{element_list} } ) { foreach my $prop (qw/summary description/) { my $info_to_move = delete $self->{model}{element}{$elt_name}{$prop}; $self->{$prop}{$elt_name} = $info_to_move if defined $info_to_move; } foreach my $prop ( keys %legal_properties ) { my $prop_v = delete $self->{model}{element}{$elt_name}{$prop} // $Config::Model::default_property{$prop} ; $self->{$prop}{$elt_name} = $prop_v; croak "Config class $self->{config_class_name} error: ", "Unknown $prop: '$prop_v'. Expected ", join( " or ", keys %{ $self->{$prop} } ) unless defined $legal_properties{$prop}{$prop_v}; } } } sub init { my $self = shift; my %args = @_; return if $self->{initialized}; $self->{initialized} = 1; # avoid recursions my $model = $self->{model}; return unless defined $model->{read_config} or defined $model->{write_config}; my $initial_load_backup = $self->instance->initial_load; $self->instance->initial_load_start; $self->{backend_mgr} ||= Config::Model::BackendMgr->new( # config_dir spec given by application info config_dir => $self->instance->config_dir, node => $self, ); if ( defined $model->{read_config} ) { $self->read_config_data( check => $args{check} // $self->check ); } # use read_config data if write_config is missing $model->{write_config} ||= dclone $model->{read_config} if defined $model->{read_config}; if ( $model->{write_config} ) { # setup auto_write, write_config_dir is obsolete $self->backend_mgr->auto_write_init( write_config => $model->{write_config}, write_config_dir => $model->{write_config_dir}, ); } $self->instance->initial_load($initial_load_backup); } sub read_config_data { my ( $self, %args ) = @_; my $model = $self->{model}; if ( $self->location and $args{config_file} ) { die "read_config_data: cannot override config_file in non root node (", $self->location, ")\n"; } # setup auto_read, read_config_dir is obsolete # may use an overridden config file $self->backend_mgr->read_config_data( read_config => $model->{read_config}, check => $args{check}, read_config_dir => $model->{read_config_dir}, config_file => $args{config_file} || $self->{config_file}, auto_create => $args{auto_create} || $self->instance->auto_create, ); } sub notify_change { my $self = shift; my %args = @_; $change_logger->debug( "called for ", $self->name, " from ", join( ' ', caller ), " with ", join( ' ', %args ) ) if $change_logger->is_debug; return if $self->instance->initial_load and not $args{really}; $logger->debug( "called while needs_write is ", $self->needs_save, " for ", $self->name ) if $logger->is_debug; if ( defined $self->backend_mgr ) { $self->needs_save(1); # will trigger a save in config_file $self->SUPER::notify_change( %args, needs_save => 0 ); } else { # save config_file will be done by a node above $self->SUPER::notify_change( %args, needs_save => 1 ); } } sub write_back { my ( $self, %args ) = @_; my $force_write = delete $args{force} || 0; if ( $self->location and $args{config_file} ) { die "write_back: cannot override config_file in non root node (", $self->location, ")\n"; } $self->backend_mgr->write_back(%args) if $self->needs_save or $force_write; } sub is_auto_write_for_type { my $self = shift; return 0 unless defined $self->backend_mgr; return $self->backend_mgr->is_auto_write_for_type(@_); } sub name { my $self = shift; return $self->location() || $self->config_class_name; } sub get_type { return 'node'; } sub get_cargo_type { return 'node'; } # always true. this method is required so that WarpedNode and Node # have a similar API. sub is_accessible { return 1; } # should I autovivify this element: NO sub has_element { my $self = shift; my %args = ( @_ > 1 ) ? @_ : ( name => shift ); my $name = $args{name}; my $type = $args{type}; if ( not defined $name ) { Config::Model::Exception::Internal->throw( object => $self, info => "has_element: missing element name", ); } $self->accept_element($name); return 0 unless defined $self->{model}{element}{$name}; return 1 unless defined $type; return $self->{model}{element}{$name}{type} eq $type ? 1 : 0; } # should I autovivify this element: NO sub find_element { my ( $self, $name, %args ) = @_; croak "find_element: missing element name" unless defined $name; # should be the case if people are using cme edit return $name if defined $self->{model}{element}{$name}; # look for a close element playing with cases; if ( defined $args{case} and $args{case} eq 'any' ) { foreach my $elt ( keys %{ $self->{model}{element} } ) { return $elt if lc($elt) eq lc($name); } } # now look if the element can be accepted $self->accept_element($name); return $name if defined $self->{model}{element}{$name}; return; } sub element_model { my $self = shift; croak "element_model: missing element name" unless @_; return $self->{model}{element}{ $_[0] }; } sub element_type { my ($self, $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 { my $self = shift; my %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(check => $args{check}); my @result; my $info = $self->{model}; my @element_list = @{ $self->{model}{element_list} }; # this is a bit convoluted, but the order of the returned element # must respect the order of the elements declared in the model by # the user foreach my $elt (@element_list) { # create element if they don't exist, this enables warp stuff # to kick in $self->create_element( name => $elt, check => $args{check} || 'yes' ) unless defined $self->{element}{$elt}; next if $self->{level}{$elt} eq 'hidden'; my $status = $self->{status}{$elt} || $default_property{status}; next if ( $status eq 'deprecated' or $status eq 'obsolete' ); my $elt_type = $self->{element}{$elt}->get_type; my $elt_cargo = $self->{element}{$elt}->get_cargo_type; if ( ( not defined $type or $type eq $elt_type ) and ( not defined $cargo_type or $cargo_type eq $elt_cargo ) ) { push @result, $elt; } } $logger->debug("got @result"); return wantarray ? @result : join( ' ', @result ); } sub children { my $self = shift; return $self->get_element_names; } sub next_element { my $self = shift; my %args = @_; my $element = $args{name}; my @elements = @{ $self->{model}{element_list} }; @elements = reverse @elements if $args{reverse}; # if element is empty, start from first element my $found_elt = ( defined $element and $element ) ? 0 : 1; while ( my $name = shift @elements ) { if ($found_elt) { return $name if $self->is_element_available( name => $name, status => $args{status} ); } $found_elt = 1 if defined $element and $element eq $name; } croak "next_element: element $element is unknown. Expected @elements" unless $found_elt; return; } sub previous_element { my $self = shift; $self->next_element( @_, reverse => 1 ); } sub get_element_property { my $self = shift; my %args = @_; my ( $prop, $elt ) = $self->check_property_args( 'get_element_property', %args ); return $self->{$prop}{$elt} || $default_property{$prop}; } sub set_element_property { my $self = shift; my %args = @_; my ( $prop, $elt ) = $self->check_property_args( 'set_element_property', %args ); my $new_value = $args{value} || croak "set_element_property:: missing 'value' parameter"; $logger->debug( "Node ", $self->name, ": set $elt property $prop to $new_value" ); return $self->{$prop}{$elt} = $new_value; } sub reset_element_property { my $self = shift; my %args = @_; my ( $prop, $elt ) = $self->check_property_args( 'reset_element_property', %args ); my $original_value = $self->{config_model}->get_element_property( class => $self->{config_class_name}, %args ); $logger->debug( "Node ", $self->name, ": reset $elt property $prop to $original_value" ); return $self->{$prop}{$elt} = $original_value; } # internal: called by the property methods to check their arguments sub check_property_args { my $self = shift; my $method_name = shift; my %args = @_; my $elt = $args{element} || croak "$method_name: missing 'element' parameter"; my $prop = $args{property} || croak "$method_name: missing 'property' parameter"; my $prop_values = $legal_properties{$prop}; confess "Unknown property in $method_name: $prop, expected status or ", "level" unless defined $prop_values; return ( $prop, $elt ); } sub fetch_element { my $self = shift; my %args = @_ > 1 ? @_ : ( name => shift ); my $element_name = $args{name}; Config::Model::Exception::Internal->throw( error => "fetch_element: missing name" ) unless defined $element_name; my $check = $self->_check_check( $args{check} ); my $accept_hidden = $args{accept_hidden} || 0; $self->init(check => $check); my $model = $self->{model}; # retrieve element (and auto-vivify if needed) if ( not defined $self->{element}{$element_name} ) { # We also need to check if element name is matched by any of 'accept' parameters $self->accept_element($element_name); $self->create_element( name => $element_name, check => $check ) or return; } # check level my $element_level = $self->get_element_property( property => 'level', element => $element_name ); if ( $element_level eq 'hidden' and not $accept_hidden ) { return 0 if ( $check eq 'no' or $check eq 'skip' ); Config::Model::Exception::UnavailableElement->throw( object => $self, element => $element_name, info => 'hidden element', ); } # check status if ( $self->{status}{$element_name} eq 'obsolete' ) { # obsolete is a status not very different from a missing # item. The only difference is that user will get more # information return 0 if ( $check eq 'no' or $check eq 'skip' ); Config::Model::Exception::ObsoleteElement->throw( object => $self, element => $element_name, ); } if ( $self->{status}{$element_name} eq 'deprecated' and $check ne 'no' ) { # FIXME elaborate more ? or include parameter description ?? warn "Element '$element_name' of node '", $self->name, "' is deprecated\n"; # this will also force a rewrite of the file even if no other # semantic change was done $self->notify_change( note => 'dropping deprecated parameter', path => $self->location . ' ' . $element_name, really => 1, ); } return $self->fetch_element_no_check($element_name); } sub fetch_element_no_check { my ( $self, $element_name ) = @_; return $self->{element}{$element_name}; } sub fetch_element_value { my $self = shift; my %args = @_ > 1 ? @_ : ( name => $_[0] ); my $element_name = $args{name}; my $check = $self->_check_check( $args{check} ); if ( $self->element_type($element_name) ne 'leaf' ) { Config::Model::Exception::WrongType->throw( object => $self->fetch_element($element_name), function => 'fetch_element_value', got_type => $self->element_type($element_name), expected_type => 'leaf', ); } return $self->fetch_element(%args)->fetch( check => $check ); } sub store_element_value { my $self = shift; my %args = @_ > 2 ? @_ : ( name => $_[0], value => $_[1] ); return $self->fetch_element(%args)->store(%args); } sub is_element_available { my $self = shift; my ( $elt_name, $status ) = ( undef, 'deprecated' ); if ( @_ == 1 ) { $elt_name = shift; } else { my %args = @_; $elt_name = $args{name}; $status = $args{status} if defined $args{status}; } croak "is_element_available: missing name parameter" unless defined $elt_name; # force the warp to be done (if possible) so the catalog name # is updated my $element = $self->fetch_element( name => $elt_name, check => 'no', accept_hidden => 1 ); my $element_level = $self->get_element_property( property => 'level', element => $elt_name ); if ( $element_level eq 'hidden' ) { $logger->trace("element $elt_name is level hidden -> return 0"); return 0; } my $element_status = $self->get_element_property( property => 'status', element => $elt_name ); if ( $element_status ne 'standard' and $element_status ne $status ) { $logger->trace("element $elt_name is status $element_status -> return 0"); return 0; } return 1; } sub accept_element { my ( $self, $name ) = @_; my $model_data = $self->{model}{element}; return $model_data->{$name} if defined $model_data->{$name}; 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); warn "Warning: ".$self->location ." '$name' is confusingly close to '$best' (edit distance is $dist)." ." Is there a typo ?\n"; } } 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 { my $self = shift; return defined $self->{element}{ $_[0] }; } sub get { my $self = shift; my %args = @_ > 1 ? @_ : ( path => $_[0] ); my $path = delete $args{path}; my $get_obj = delete $args{get_obj} || 0; $path =~ s!^/!!; return $self unless length($path); my ( $item, $new_path ) = split m!/!, $path, 2; $logger->debug("get: path $path, item $item"); my $elt = $self->fetch_element( name => $item, %args ); return unless defined $elt; return $elt if ( ( $elt->get_type ne 'leaf' or $get_obj ) and not defined $new_path ); return $elt->get( path => $new_path, get_obj => $get_obj, %args ); } sub set { my $self = shift; my $path = shift; $path =~ s!^/!!; my ( $item, $new_path ) = split m!/!, $path, 2; if ( $item =~ /([\w\-]+)\[(\d+)\]/ ) { return $self->fetch_element($1)->fetch_with_id($2)->set( $new_path, @_ ); } else { return $self->fetch_element($item)->set( $new_path, @_ ); } } sub load { my $self = shift; my $loader = Config::Model::Loader->new; my %args = @_ eq 1 ? ( steps => $_[0] ) : @_; if ( defined $args{step} || defined $args{steps}) { $loader->load( node => $self, %args ); } else { Config::Model::Exception::Load->throw( object => $self, message => "load called with no 'steps' parameter", ); } } sub load_data { my $self = shift; my %args = @_ > 1 ? @_ : ( data => shift ); my $raw_perl_data = delete $args{data}; my $check = $self->_check_check( $args{check} ); if ( not defined $raw_perl_data or ( ref($raw_perl_data) ne 'HASH' #and not $raw_perl_data->isa( 'HASH' ) ) ) { Config::Model::Exception::LoadData->throw( object => $self, message => "load_data called with non hash ref arg", wrong_data => $raw_perl_data, ) if $check eq 'yes'; return; } my $perl_data = dclone $raw_perl_data ; $logger->info( "Node load_data (", $self->location, ") will load elt ", join( ' ', keys %$perl_data ) ); # data must be loaded according to the element order defined by # the model. This will not load not yet accepted parameters foreach my $elt ( @{ $self->{model}{element_list} } ) { $logger->trace("check element $elt"); next unless defined $perl_data->{$elt}; if ( $self->is_element_available( name => $elt ) or $check eq 'no' ) { if ( $logger->is_trace ) { my $v = defined $perl_data->{$elt} ? $perl_data->{$elt} : ''; $logger->trace("Node load_data for element $elt -> $v"); } my $obj = $self->fetch_element( name => $elt, check => $check ); if ($obj) { $obj->load_data( %args, data => delete $perl_data->{$elt} ); } elsif ( defined $obj ) { # skip hidden elements and trash corresponding data $logger->trace("Node load_data drop element $elt"); delete $perl_data->{$elt}; } } elsif ( $check eq 'skip' ) { $logger->trace("Node load_data skips element $elt"); } else { Config::Model::Exception::LoadData->throw( message => "load_data: tried to load hidden " . "element '$elt' with", wrong_data => $perl_data->{$elt}, object => $self, ); } } # Load elements matched by accept parameter if ( defined $self->{model}{accept} ) { # Now, $perl_data contains all elements not yet parsed # sort is required to have a predictable order of accepted elements foreach my $elt ( sort keys %$perl_data ) { #load value #TODO: annotations my $obj = $self->fetch_element( name => $elt, check => $check ); next unless $obj; # in cas of known but unavailable elements $logger->debug("Node load_data: accepting element $elt"); $obj->load_data( %args, data => delete $perl_data->{$elt} ) if defined $obj; } } if ( %$perl_data and $check eq 'yes' ) { Config::Model::Exception::LoadData->throw( message => "load_data: unknown elements (expected " . join( ' ', @{ $self->{model}{element_list} } ) . ") ", wrong_data => $perl_data, object => $self, ); } } # TBD explain full_dump sub dump_tree { my $self = shift; my %args = @_; $self->init(check => $args{check}); my $dumper = Config::Model::Dumper->new; $dumper->dump_tree( node => $self, @_ ); } sub migrate { my $self = shift; my %args = @_; $self->init(check => $args{check}); Config::Model::Dumper->new->dump_tree( node => $self, mode => 'full', @_ ); return $self->needs_save; } sub dump_annotations_as_pod { my $self = shift; my %args = @_; $self->init(check => $args{check}); my $dumper = Config::Model::DumpAsData->new; $dumper->dump_annotations_as_pod( node => $self, @_ ); } sub describe { my $self = shift; my %args = @_; $self->init(check => $args{check}); my $descriptor = Config::Model::Describe->new; $descriptor->describe( node => $self, @_ ); } sub report { my $self = shift; my %args = @_; $self->init(check => $args{check}); my $reporter = Config::Model::Report->new; $reporter->report( node => $self ); } sub audit { my $self = shift; my %args = @_; $self->init(check => $args{check}); my $reporter = Config::Model::Report->new; $reporter->report( node => $self, audit => 1 ); } sub copy_from { my $self = shift; my %args = @_ > 1 ? @_ : ( from => shift ); my $from = $args{from} || croak "copy_from: missing from argument"; my $check = $args{check} || 'yes'; $logger->debug( "node " . $self->location . " copy from " . $from->location ); my $dump = $from->dump_tree( check => 'no' ); $self->load( step => $dump, check => $check ); } # TODO: need Pod::Text attribute -> move that to a role ? # to translate Pod description to plain text when help is displayed sub get_help { my $self = shift; my $help; if ( scalar @_ > 1 ) { my ( $tag, $elt_name ) = @_; if ( $tag !~ /summary|description/ ) { croak "get_help: wrong argument $tag, expected ", "'description' or 'summary'"; } $help = $self->{$tag}{$elt_name}; } elsif (@_) { $help = $self->{description}{ $_[0] }; } else { $help = $self->{model}{class_description}; } return defined $help ? $help : ''; } sub tree_searcher { my $self = shift; return Config::Model::TreeSearcher->new( node => $self, @_ ); } sub apply_fixes { my $self = shift; my $filter = shift || '.'; # define leaf call back my $fix_leaf = sub { my ( $scanner, $data_ref, $node, $element_name, $index, $leaf_object ) = @_; $leaf_object->apply_fixes if $element_name =~ /$filter/; }; my $fix_hash = sub { my ( $scanner, $data_r, $node, $element, @keys ) = @_; return unless @keys; # leaves must be fixed before the hash, hence the # calls to scan_hash before apply_fixes map { $scanner->scan_hash( $data_r, $node, $element, $_ ) } @keys; $node->fetch_element($element)->apply_fixes if $element =~ /$filter/; }; my $fix_list = sub { my ( $scanner, $data_r, $node, $element, @keys ) = @_; return unless @keys; map { $scanner->scan_list( $data_r, $node, $element, $_ ) } @keys; $node->fetch_element($element)->apply_fixes if $element =~ /$filter/; }; my $scan = Config::Model::ObjTreeScanner->new( hash_element_cb => $fix_hash, list_element_cb => $fix_list, leaf_cb => $fix_leaf, check => 'no', ); $fix_logger->debug( "apply fix started from ", $self->name ); $scan->scan_node( undef, $self ); $fix_logger->debug("apply fix done"); } sub deep_check { my $self = shift; my %args = @_; $deep_check_logger->debug("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->debug( "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->debug("deep check done"); } __PACKAGE__->meta->make_immutable; 1; # ABSTRACT: Class for configuration tree node __END__ =pod =encoding UTF-8 =head1 NAME Config::Model::Node - Class for configuration tree node =head1 VERSION version 2.097 =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 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 =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

For more information, see this blog.

=back =head1 Element declaration =head2 Element type Each element is declared with a list ref that contains all necessary information: element => [ foo => { ... } ] This most important information from this hash ref is the mandatory B parameter. The I type can be: =over 8 =item C The element is a simple node of a tree instantiated from a configuration class (declared with L). See L. =item C The element is a node whose properties (mostly C) can be changed (warped) according to the values of one or more leaf elements in the configuration tree. See L for details. =item C The element is a scalar value. See L =item C The element is a collection of nodes or values (default). Each element of this collection is identified by a string (Just like a regular hash, except that you can set up constraint of the keys). See L =item C The element is a collection of nodes or values (default). Each element of this collection is identified by an integer (Just like a regular perl array, except that you can set up constraint of the keys). See L =item C The element is a collection of values which are unique in the check_list. See L. =item C Override the default class for leaf, list and hash elements. The override class be inherit L for leaf element, L for hash element and L for list element. =back =head2 Node element When declaring a C element, you must also provide a C parameter. For instance: $model ->create_config_class ( name => "ClassWithOneNode", element => [ the_node => { type => 'node', config_class_name => 'AnotherClass', }, ] ) ; =head2 Leaf element When declaring a C element, you must also provide a C parameter. See L for more details. =head2 Hash element When declaring a C element, you must also provide a C parameter. You can also provide a C parameter set to C or C (default). See L and L for more details. =head2 List element You can also provide a C parameter set to C or C (default). See L and L for more details. =head1 Constructor The C constructor accepts the following parameters: =over =item config_file Specify configuration file to be used by backend. This parameter may override a file declared in the model. Note that this parameter is not propagated in children nodes. =back =head1 Introspection methods =head2 name Returns the location of the node, or its config class name (for root node). =head2 get_type Returns C. =head2 config_model Returns the B configuration model (L object). =head2 model Returns the configuration model of this node (data structure). =head2 config_class_name Returns the configuration class name of this node. =head2 instance Returns the instance object containing this node. Inherited from L =head2 has_element ( name => element_name, [ type => searched_type ] ) Returns 1 if the class model has the element declared or if the element name is matched by the optional C parameter. If C is specified, the element name must also match the type. =head2 find_element ( element_name , [ case => any ]) Returns 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 (respecting privilege level). This method returns a L object. See L for details on how to handle a search. This method is inherited from L. =head2 element_model ( element_name ) Returns model of the element. =head2 element_type ( element_name ) Returns the type (e.g. leaf, hash, list, checklist or node) of the element. 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 elements names available. Optional parameters are: =over =item * B: Returns only element of requested type (e.g. C, C, C,...). By default return elements of any type. =item * B: Returns only 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 ( name => element_name ) This method provides a way to iterate through the elements of a node. Returns the previous element name. Returns undef if no previous element is available. =head2 get_element_property ( element => ..., property => ... ) Retrieve a property of an element. I.e. for a model : status => [ X => 'deprecated' ] element => [ X => { ... } ] This call returns C: $node->get_element_property ( element => 'X', property => 'status' ) =head2 set_element_property ( element => ..., property => ... ) Set a property of an element. =head2 reset_element_property ( element => ... ) Reset a property of an element according to the original model. =head1 Information management =head2 fetch_element ( name => .. , [ check => ..] ) Fetch and returns an element from a node. check can be set to yes, no or skip. When check is C or C, can return C when the element is unknown, or 0 if the element is not available (hidden). =head2 fetch_element_value ( name => ... [ check => ...] ) Fetch and returns the I of a leaf element from a node. =head2 store_element_value ( name, value ) Store a I in a leaf element from a node. Can be invoked with named parameters (name, value, check) =head2 is_element_available( name => ..., ) Returns 1 if the element C is available and if the element is not "hidden". Returns 0 otherwise. As a syntactic sugar, this method can be called with only one parameter: is_element_available( 'element_name' ) ; =head2 accept_element( name ) Checks and returns the appropriate model of an acceptable element (i.e. declared as a model C or part of an C declaration). Returns undef if the element cannot be accepted. =head2 accept_regexp( name ) Returns the list of regular expressions used to check for acceptable parameters. Useful for diagnostics. =head2 element_exists( element_name ) Returns 1 if the element is known in the model. =head2 is_element_defined( element_name ) Returns 1 if the element is defined. =head2 grab See L. =head2 grab_value See L. =head2 grab_root See L. =head2 get( path => ..., mode => ... , check => ... , get_obj => 1|0, autoadd => 1|0) Get a value from a directory like path. If C is 1, C returns a leaf object instead of returning its value. =head2 set( 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 ( 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 ( 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. =head2 needs_save return 1 if one of the elements of the node's sub-tree has been modified. =head1 Serialization =head2 dump_tree ( ... ) Dumps the configuration data of the node and its siblings into a string. See L for parameter details. This string follows the syntax defined in L. The string produced by C can be passed to C. =head2 dump_annotations_as_pod ( ... ) Dumps the configuration annotations of the node and its siblings into a string. See L for parameter details. =head2 describe ( [ element => ... ] ) Provides a description of the node elements or of one element. =head2 report () Provides a text report on the content of the configuration below this node. =head2 audit () Provides a text audit on the content of the configuration below this node. This audit shows only value different from their default value. =head2 copy_from ( from => another_node_object, [ check => ... ] ) Copy configuration data from another node into this node and its siblings. The copy can be made in a I mode where invalid data is discarded with C<< check => skip >>. This method can be called with a single argument: C<< copy_from($another_node) >> =head1 Help management =head2 get_help ( [ [ description | summary ] => element_name ] ) If called without element, returns the description of the class (Stored in C attribute of a node declaration). If called with an element name, returns the description of the element (Stored in C attribute of a node declaration). If called with 2 argument, either return the C or the C of the element. Returns an empty string if no description was found. =head2 tree_searcher( type => ... ) Returns an object able to search the configuration tree. Parameters are : =over =item type Where to perform the search. It can be C, C, C, C, C, C or C. =back 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-2016 by Dominique Dumont. This is free software, licensed under: The GNU Lesser General Public License, Version 2.1, February 1999 =cut Config-Model-2.097/lib/Config/Model/Instance.pm0000644000175000017500000005512713027007223017563 0ustar domidomi# # This file is part of Config-Model # # This software is Copyright (c) 2005-2016 by Dominique Dumont. # # This is free software, licensed under: # # The GNU Lesser General Public License, Version 2.1, February 1999 # package Config::Model::Instance; $Config::Model::Instance::VERSION = '2.097'; #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 Text::Diff; use File::Path; use Log::Log4perl qw(get_logger :levels); 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"); has [qw/root_class_name/] => ( is => 'ro', isa => 'Str', required => 1 ); sub location { return "in instance" } has config_model => ( is => 'ro', isa => 'Config::Model', weak_ref => 1, required => 1 ); has check => ( is => 'ro', isa => 'Str', default => 'yes', reader => 'read_check', ); has auto_create => ( is => 'ro', isa => 'Bool', default => 0, ); # a unique (instance wise) placeholder for various tree objects # to store information has _safe => ( is => 'rw', isa => 'HashRef', traits => ['Hash'], default => sub { {} }, handles => { data => 'accessor', }, ); # preset mode: to load values found by HW scan or other automatic scheme # layered mode: to load values found in included files (e.g. a la multistrap) has [qw/preset layered/] => ( is => 'ro', isa => 'Bool', default => 0, ); has changes => ( is => 'ro', isa => 'ArrayRef', traits => ['Array'], default => sub { [] }, handles => { add_change => 'push', c_count => 'count', #needs_save => 'count' , clear_changes => 'clear', } ); sub needs_save { my $self = shift; my $arg = shift; if ( defined $arg ) { if ($arg) { carp "replace needs_save(1) call with add_change"; $self->add_change(); # may not work } else { carp "replace needs_save(0) call with clear_changes"; $self->clear_changes; } } return $self->c_count; } has errors => ( is => 'ro', isa => 'HashRef', traits => ['Hash'], default => sub { {} }, handles => { _set_error => 'set', cancel_error => 'delete', has_error => 'count', clear_errors => 'clear', error_paths => 'keys' } ); sub add_error { my $self = shift; $self->_set_error( shift, '' ); } sub error_messages { my $self = shift; my @errs = map { "$_: " . $self->config_root->grab($_)->error_msg } $self->error_paths; return wantarray ? @errs : join( "\n", @errs ); } sub has_warning { my $self = shift; my $count_leaf_warnings = sub { my ( $scanner, $data_ref, $node, $element_name, $index, $leaf_object ) = @_; $$data_ref += $leaf_object->has_warning; }; my $count_list_warnings = sub { my ( $scanner, $data_ref, $node, $element_name, $index, $leaf_object ) = @_; $$data_ref += $node->fetch_element($element_name)->has_warning; }; my $scan = Config::Model::ObjTreeScanner->new( leaf_cb => $count_leaf_warnings, list_element_hook => $count_list_warnings, hash_element_hook => $count_list_warnings, ); my $result = 0; $scan->scan_node( \$result, $self->config_root ); return $result; } has on_change_cb => ( is => 'rw', traits => ['Code'], isa => 'CodeRef', default => sub { sub { } }, ); has on_message_cb => ( traits => ['Code'], is => 'rw', isa => 'CodeRef', default => sub { sub { say @_; } }, handles => { show_message => 'execute', }, ); # initial_load mode: when data is loaded the first time has initial_load => ( is => 'rw', isa => 'Bool', default => 0, trigger => \&_trace_initial_load, traits => [qw/Bool/], handles => { initial_load_start => 'set', initial_load_stop => 'unset', } ); sub _trace_initial_load { my ( $self, $n, $o ) = @_; $logger->debug("switched to $n"); } # This array holds a set of sub ref that will be invoked when # the users requires to write all configuration tree in their # backend storage. has _write_back => ( is => 'ro', isa => 'ArrayRef', traits => ['Array'], handles => { register_write_back => 'push', count_write_back => 'count', # mostly for tests }, default => sub { [] }, ); # used for auto_read auto_write feature has [qw/name application root_dir backend backup/] => ( is => 'ro', isa => 'Maybe[Str]', ); has read_root_dir => ( is => 'ro', isa => 'Str', lazy_build => 1, ); sub _build_read_root_dir { my $self = shift; my $root_dir = $self->root_dir // ''; # cleanup paths $root_dir .= '/' if $root_dir and $root_dir !~ m!/$! ; return $root_dir; } # config_file cannot be a Path::Tiny object: it may be a file name # relative to a directory only known by a backend (e.g. a patch in # debian/patches directory) has config_file => (is => 'ro', isa => 'Maybe[Str]'); has config_dir => (is => 'ro', isa => 'Maybe[Str]'); has tree => ( is => 'ro', isa => 'Config::Model::Node', builder => 'reset_config', reader => 'config_root', handles => [qw/apply_fixes deep_check/], ); sub reset_config { my $self = shift; return $self->load_node ( config_class_name => $self->{root_class_name}, instance => $self, container => $self, check => $self->read_check, config_file => $self->{config_file}, ); } sub preset_start { my $self = shift; $logger->info("Starting preset mode"); carp "Cannot start preset mode during layered mode" if $self->{layered}; $self->{preset} = 1; } sub preset_stop { my $self = shift; $logger->info("Stopping preset mode"); $self->{preset} = 0; } sub preset_clear { my $self = shift; my $leaf_cb = sub { my ( $scanner, $data_ref, $node, $element_name, $index, $leaf_object ) = @_; $leaf_object->clear_preset; }; $self->_stuff_clear($leaf_cb); } sub layered_start { my $self = shift; $logger->info("Starting layered mode"); carp "Cannot start layered mode during preset mode" if $self->{preset}; $self->{layered} = 1; } sub layered_stop { my $self = shift; $logger->info("Stopping layered mode"); $self->{layered} = 0; } sub layered_clear { my $self = shift; my $leaf_cb = sub { my ( $scanner, $data_ref, $node, $element_name, $index, $leaf_object ) = @_; $$data_ref ||= $leaf_object->clear_layered; }; $self->_stuff_clear($leaf_cb); } sub get_data_mode { my $self = shift; return $self->{layered} ? 'layered' : $self->{preset} ? 'preset' : 'normal'; } sub _stuff_clear { my ( $self, $leaf_cb ) = @_; # this sub may remove hash keys that were entered by user if the # corresponding hash value has no data. # it also clear auto_created ids if there's no data in there my $h_cb = sub { my ( $scanner, $data_ref, $node, $element_name, @keys ) = @_; my $obj = $node->fetch_element($element_name); foreach my $k (@keys) { my $has_data = 0; $scanner->scan_hash( \$has_data, $node, $element_name, $k ); $obj->remove($k) unless $has_data; $$data_ref ||= $has_data; } }; my $wiper = Config::Model::ObjTreeScanner->new( fallback => 'all', auto_vivify => 0, check => 'skip', leaf_cb => $leaf_cb, hash_element_cb => $h_cb, list_element_cb => $h_cb, ); $wiper->scan_node( undef, $self->config_root ); } sub modify { my $self = shift ; my %args = @_ eq 1 ? ( step => $_[0] ) : @_; my $force = delete $args{force_save} || delete $args{force}; $self->load(%args)->write_back( force => $force ); return $self; } sub load { my $self = shift; my $loader = Config::Model::Loader->new; my %args = @_ eq 1 ? ( step => $_[0] ) : @_; $loader->load( node => $self->{tree}, %args ); return $self; } sub search_element { my $self = shift; $self->{tree}->search_element(@_); } sub wizard_helper { carp __PACKAGE__, "::wizard_helper helped is deprecated. Call iterator instead"; goto &iterator; } sub iterator { my $self = shift; my @args = @_; my $tree_root = $self->config_root; return Config::Model::Iterator->new( root => $tree_root, @args ); } sub read_directory { carp "read_directory is deprecated"; return shift->read_root_dir; } sub write_directory { my $self = shift; carp "write_directory is deprecated"; return $self->read_root_dir; } sub write_root_dir { my $self = shift; return $self->read_root_dir; } # FIXME: record changes to implement undo/redo ? sub notify_change { my $self = shift; my %args = @_; if ( $change_logger->is_debug ) { $change_logger->debug( "in instance ", $self->name, ' for path ', $args{path} ); } foreach my $obsolete (qw/note_only msg/) { if ( my $m = delete $args{$obsolete} ) { carp "notify_change: param $obsolete is obsolete ($m)"; $args{note} //=''; $args{note} .= $m; } } $self->add_change( \%args ); $self->on_change_cb->( %args ); } sub list_changes { my $self = shift; my $l = $self->changes; my @all; foreach my $c (@$l) { my $path = $c->{path} ; $path .= ': ' if $path; my $vt = $c->{value_type} || ''; my ( $o, $n ) = map { $_ // ''; } ( $c->{old}, $c->{new} ); if ( $vt eq 'string' and ( $o =~ /\n/ or $n =~ /\n/ ) ) { # append \n if needed so diff works as expected map { $_ .= "\n" unless /\n$/; } ( $o, $n ); my $diff = diff \$o, \$n; push @all, $path . ( $c->{note} ? " # $c->{note}" : '' ) . "\n" . $diff; } elsif ( defined $c->{old} or defined $c->{new} ) { map { s/\n.*/.../s; } ( $o, $n ); push @all, $path."'$o' -> '$n'" . ( $c->{note} ? " # $c->{note}" : '' ); } elsif (defined $c->{note}){ push @all, $path.$c->{note}; } else { # something's unexpected with the call to notify_change push @all, "changed ".join(' ', each %$c); } } return wantarray ? @all : join( "\n", @all ); } sub say_changes { my $self = shift; my @changes = $self->list_changes; say "\n", join( "\n- ", "Changes applied to " . ($self->application // $self->name) . " configuration:", @changes ), "\n" if @changes; return @changes; } sub write_back { my $self = shift; my %args = scalar @_ > 1 ? @_ : scalar @_ == 1 ? ( config_dir => $_[0] ) : (); my $force_backend = delete $args{backend} || $self->{backend}; my $force_write = delete $args{force} || 0; # 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 ( keys %args ) { if (/^(root|config_dir)$/) { $args{$_} ||= ''; $args{$_} .= '/' if $args{$_} and $args{$_} !~ m(/$); } elsif ( not /^config_file$/ ) { croak "write_back: wrong parameters $_"; } } if (not @{ $self->{_write_back} }) { my $info = $self->application ? "the model of application ".$self->application : "model ".$self->root_cladd_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 ( @{ $self->{_write_back} } ) { $logger->info("write_back called on node $path"); my $node = $self->config_root->grab( step => $path, type => 'node' ); $node->write_back( %args, config_file => $self->{config_file}, backend => $force_backend, force => $force_write, backup => $self->backup, ); } $self->clear_changes; } sub 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')) { say "Calling update on ",$node->name, ' ',$node->config_class_name, " $node" unless $args{quiet}; push (@msgs, $node->update(%args)) } ; }; my $root = $self->config_root ; Config::Model::ObjTreeScanner->new( node_content_hook => $hook, check => ($args{quiet} ? 'no' : 'yes'), leaf_cb => sub { } )->scan_node( \@msgs, $root ); return @msgs; } __PACKAGE__->meta->make_immutable; 1; # ABSTRACT: Instance of configuration tree __END__ =pod =encoding UTF-8 =head1 NAME Config::Model::Instance - Instance of configuration tree =head1 VERSION version 2.097 =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: =over =item root_dir Pseudo root directory where to read I write configuration files. Configuration directory specified in model or with C option is appended to this root directory =item config_dir Directory to read or write configuration file. This parameter must be supplied if not provided by the configuration model. =item backend Specify which backend to use. See L for details =item 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 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 'no'> ). =head1 METHODS =head2 Manage configuration data =head2 modify ( ... ) Calls L and then L. Takes the same parameter as C plus C to force saving configuration file even if no value was modified (default is 0) =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. (alias to C) =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 list_changes In list context, returns a array ref of strings describing the changes. In scalar context, returns a big string. Useful to print. =head2 say_changes Print all changes on STDOUT and return the list of changes. =head2 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( 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 searcher ( ) Returns an object dedicated to search an element in the configuration model (respecting privilege level). This method returns a L object. See L for details on how to handle a search. =head2 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( string ) Display the message on STDOUT unless a custom function was passed to C parameter. =head2 reset_config Destroy current configuration tree (with data) and returns a new tree with data (and annotations) loaded from disk. =head2 config_model() Returns the model (L object) of the configuration tree. =head2 annotation_saver() Returns the object loading and saving annotations. See L for details. =head2 preset_start () All values stored in preset mode are shown to the user as default values. This feature is useful to enter configuration data entered by an automatic process (like hardware scan) =head2 preset_stop () Stop preset mode =head2 preset () Get preset mode =head2 preset_clear() Clear all preset values stored. =head2 layered_start () All values stored in layered mode are shown to the user as default values. This feature is useful to enter configuration data entered by an automatic process (like hardware scan) =head2 layered_stop () Stop layered mode =head2 layered () Get layered mode =head2 layered_clear() Clear all layered values stored. =head2 get_data_mode Returns 'normal' or 'preset' or 'layered'. Does not take into account initial_load. =head2 initial_load_stop () Stop initial_load mode. Instance is built with initial_load as 1. Read backend clears this value once the first read is done. =head2 initial_load () Get initial_load mode =head2 data( kind, [data] ) The data method provide a way to store some arbitrary data in the instance object. =head1 Auto read and write feature Usually, a program based on config model must first create the configuration model, then load all configuration data. This feature enables you to declare with the model a way to load configuration data (and to write it back). See L for details. =head2 backend() Get the preferred backend method for this instance (as passed to the constructor). =head2 root_dir() Returns root directory where configuration data is read from or written to. =head2 register_write_back ( node_location ) Register a node path that 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 until one succeeds (returns true). (See L for details). You can specify here a pseudo root directory or another config directory to write configuration data back with C and C parameters. This overrides the model specifications. You can force to use a backend by specifying C<< backend => xxx >>. For instance, C<< backend => 'augeas' >> or C<< backend => 'custom' >>. You can force to use all backend to write the files by specifying C<< backend => 'all' >>. C croaks if no write call-back are known. =head1 AUTHOR Dominique Dumont, (ddumont at cpan dot org) =head1 SEE ALSO L, L, L, L, L, =head1 AUTHOR Dominique Dumont =head1 COPYRIGHT AND LICENSE This software is Copyright (c) 2005-2016 by Dominique Dumont. This is free software, licensed under: The GNU Lesser General Public License, Version 2.1, February 1999 =cut Config-Model-2.097/lib/Config/Model/models/0000755000175000017500000000000013027007223016732 5ustar domidomiConfig-Model-2.097/lib/Config/Model/models/PopCon.pod0000644000175000017500000000541613027007223020642 0ustar domidomi# PODNAME: Config::Model::models::PopCon # ABSTRACT: Configuration class PopCon =encoding utf8 =head1 NAME Config::Model::models::PopCon - Configuration class PopCon =head1 DESCRIPTION Configuration classes used by L =head1 Elements =head2 PARTICIPATE If you don't want to participate in the contest, say "no" and we won't send messages. I<< Optional. Type boolean. upstream_default: '0'. >> =head2 ENCRYPT - support for encrypted submissions encrypt popcon submission. Eventually, this feature wil be enabled by default. I<< Optional. Type enum. choice: 'no', 'maybe', 'yes'. upstream_default: 'no'. >> Here are some explanations on the possible values: =over =item 'maybe' encrypt if gpg is available =item 'yes' try to encrypt and fail if gpg is not available =back =head2 MAILTO - survey e-mail Specifies the address to e-mail statistics to each week. I<< Optional. Type uniline. upstream_default: 'survey@popcon.debian.org'. >> =head2 MAILFROM - forged sender email address MAILFROM is the forged sender email address you want to use in email submitted to the popularity-contest. If this is commented out, no From: or Sender: lines will be added to the outgoing mail, and it will be your MTA's job to add them. This is usually what you want. If your MTA is misconfigured or impossible to configure correctly, and it always generates invalid From: and/or Sender: lines, you can force different results by setting MAILFROM here. This can cause problems with spam bouncers, so most people should leave it commented out. I<< Optional. Type uniline. >> =head2 SUBMITURLS - list of urls to submit data to Space separated list of where to submit popularity-contest reports using http. I<< Optional. Type uniline. upstream_default: 'http://popcon.debian.org/cgi-bin/popcon.cgi'. >> =head2 USEHTTP enables http reporting. Set this to 'yes' to enable it. I<< Optional. Type boolean. upstream_default: '1'. >> =head2 HTTP_PROXY Allows one to specify an HTTP proxy server, the syntax is "http://proxy:port". This overrides the environment variable http_proxy. I<< Optional. Type uniline. >> =head2 MY_HOSTID Secret number that the popularity-contest receiver uses to keep track of your submissions. Whenever you send in a new entry, it overwrites the last one that had the same HOSTID. This key was generated automatically so you should normally just leave it alone. I<< Optional. Type uniline. >> =head2 DAY - day of week Only run on the given day, to spread the load on the server a bit. 0 is Sunday, 6 is Saturday. I<< Optional. Type integer. >> =head1 SEE ALSO =over =item * L =back =head1 AUTHOR =over =item Dominique Dumont =back =head1 COPYRIGHT =over =item 2010,2011 Dominique Dumont =back =head1 LICENSE =over =item LGPL2 =back =cut Config-Model-2.097/lib/Config/Model/models/Multistrap.pl0000644000175000017500000001255413027007223021442 0ustar domidomi# # This file is part of Config-Model # # This software is Copyright (c) 2005-2016 by Dominique Dumont. # # This is free software, licensed under: # # The GNU Lesser General Public License, Version 2.1, February 1999 # [ { 'accept' => [ '\\w+', { 'type' => 'leaf', 'value_type' => 'uniline', 'warn' => 'Handling unknown parameter as uniline value.' } ], 'class_description' => 'Class for multistrap configuration files. Note that multistrap is based on INI where section and keys are case insensitive. Hence all sections and keys are converted to lower case and written back as lower case. Most values (but not all) are also case-insensitive. These values will also be written back as lowercase.', 'element' => [ 'include', { 'class' => 'Config::Model::Value::LayeredInclude', 'convert' => 'lc', 'description' => 'To support multiple variants of a basic (common) configuration, "multistrap" allows configuration files to include other (more general) configuration files. i.e. the most detailed / specific configuration file is specified on the command line and that file includes another file which is shared by other configurations.', 'summary' => 'Include file for cascaded configuration', 'type' => 'leaf', 'value_type' => 'uniline' }, 'arch', { 'choice' => [ 'alpha', 'arm', 'armel', 'powerpc' ], 'type' => 'leaf', 'value_type' => 'enum' }, 'directory', { 'description' => 'top level directory where the bootstrap will be created', 'summary' => 'target directory', 'type' => 'leaf', 'value_type' => 'uniline' }, 'aptsources', { 'cargo' => { 'convert' => 'lc', 'refer_to' => '- sections', 'type' => 'leaf', 'value_type' => 'reference' }, 'description' => 'aptsources is a list of sections to be used in the /etc/apt/sources.list.d/multistrap.sources.list of the target. Order is not important.', 'duplicates' => 'forbid', 'type' => 'list' }, 'bootstrap', { 'cargo' => { 'convert' => 'lc', 'refer_to' => '- sections', 'type' => 'leaf', 'value_type' => 'reference' }, 'description' => 'the bootstrap option determines which repository is used to calculate the list of Priority: required packages and which packages go into the rootfs. The order of sections is not important.', 'duplicates' => 'forbid', 'type' => 'list' }, 'debootstrap', { 'cargo' => { 'convert' => 'lc', 'refer_to' => '- sections', 'type' => 'leaf', 'value_type' => 'reference' }, 'description' => 'Replaced by bootstrap parameter', 'duplicates' => 'forbid', 'status' => 'deprecated', 'type' => 'list' }, 'omitrequired', { 'type' => 'leaf', 'value_type' => 'boolean' }, 'addimportant', { 'type' => 'leaf', 'value_type' => 'boolean' }, 'configscript', { 'convert' => 'lc', 'type' => 'leaf', 'value_type' => 'uniline' }, 'setupscript', { 'convert' => 'lc', 'type' => 'leaf', 'value_type' => 'uniline' }, 'cleanup', { 'description' => 'remove apt cache data, downloaded Packages files and the apt package cache.', 'type' => 'leaf', 'value_type' => 'boolean' }, 'noauth', { 'description' => 'allow the use of unauthenticated repositories', 'type' => 'leaf', 'value_type' => 'boolean' }, 'explicitsuite', { 'description' => 'whether to add the /suite to be explicit about where apt needs to look for packages.', 'type' => 'leaf', 'upstream_default' => '0', 'value_type' => 'boolean' }, 'unpack', { 'convert' => 'lc', 'migrate_from' => { 'formula' => '$old', 'variables' => { 'old' => '- forceunpack' } }, 'summary' => 'extract all downloaded archives', 'type' => 'leaf', 'upstream_default' => '1', 'value_type' => 'boolean' }, 'sections', { 'cargo' => { 'config_class_name' => 'Multistrap::Section', 'type' => 'node' }, 'convert' => 'lc', 'index_type' => 'string', 'type' => 'hash' }, 'forceunpack', { 'convert' => 'lc', 'description' => 'deprecated. Replaced by unpack', 'status' => 'deprecated', 'summary' => 'extract all downloaded archives', 'type' => 'leaf', 'upstream_default' => '1', 'value_type' => 'boolean' } ], 'name' => 'Multistrap', 'read_config' => [ { 'auto_create' => '1', 'backend' => 'IniFile', 'force_lc_key' => '1', 'force_lc_section' => '1', 'join_list_value' => ' ', 'section_map' => { 'general' => '!' }, 'split_list_value' => '\\s+', 'store_class_in_hash' => 'sections', 'write_boolean_as' => [ 'false', 'true' ] } ] } ] ; Config-Model-2.097/lib/Config/Model/models/PopCon.pl0000644000175000017500000000755313027007223020477 0ustar domidomi# # This file is part of Config-Model # # This software is Copyright (c) 2005-2016 by Dominique Dumont. # # This is free software, licensed under: # # The GNU Lesser General Public License, Version 2.1, February 1999 # [ { 'author' => [ 'Dominique Dumont' ], 'copyright' => [ '2010,2011 Dominique Dumont' ], 'element' => [ 'PARTICIPATE', { 'description' => 'If you don\'t want to participate in the contest, say "no" and we won\'t send messages.', 'type' => 'leaf', 'upstream_default' => '0', 'value_type' => 'boolean', 'write_as' => [ 'no', 'yes' ] }, 'ENCRYPT', { 'choice' => [ 'no', 'maybe', 'yes' ], 'description' => 'encrypt popcon submission. Eventually, this feature wil be enabled by default.', 'help' => { 'maybe' => 'encrypt if gpg is available', 'yes' => 'try to encrypt and fail if gpg is not available' }, 'summary' => 'support for encrypted submissions', 'type' => 'leaf', 'upstream_default' => 'no', 'value_type' => 'enum' }, 'MAILTO', { 'description' => 'Specifies the address to e-mail statistics to each week.', 'summary' => 'survey e-mail', 'type' => 'leaf', 'upstream_default' => 'survey@popcon.debian.org', 'value_type' => 'uniline' }, '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.', 'summary' => 'forged sender email address', 'type' => 'leaf', 'value_type' => 'uniline' }, 'SUBMITURLS', { 'description' => 'Space separated list of where to submit popularity-contest reports using http.', 'summary' => 'list of urls to submit data to', 'type' => 'leaf', 'upstream_default' => 'http://popcon.debian.org/cgi-bin/popcon.cgi', 'value_type' => 'uniline' }, 'USEHTTP', { 'description' => 'enables http reporting. Set this to \'yes\' to enable it.', 'type' => 'leaf', 'upstream_default' => '1', 'value_type' => 'boolean', 'write_as' => [ 'no', '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.', 'type' => 'leaf', 'value_type' => 'uniline' }, '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. ', 'type' => 'leaf', 'value_type' => 'uniline' }, 'DAY', { 'description' => 'Only run on the given day, to spread the load on the server a bit. 0 is Sunday, 6 is Saturday. ', 'max' => '6', 'summary' => 'day of week', 'type' => 'leaf', 'value_type' => 'integer' } ], 'license' => 'LGPL2', 'name' => 'PopCon', 'read_config' => [ { 'backend' => 'ShellVar', 'config_dir' => '/etc', 'file' => 'popularity-contest.conf' } ] } ] ; Config-Model-2.097/lib/Config/Model/models/Fstab.pl0000644000175000017500000000242713027007223020333 0ustar domidomi# # This file is part of Config-Model # # This software is Copyright (c) 2005-2016 by Dominique Dumont. # # This is free software, licensed under: # # The GNU Lesser General Public License, Version 2.1, February 1999 # [ { 'author' => [ 'Dominique Dumont' ], 'class_description' => 'static information about the filesystems. fstab contains descriptive information about the various file systems. ', 'copyright' => [ '2010,2011 Dominique Dumont' ], 'element' => [ 'fs', { 'cargo' => { 'config_class_name' => 'Fstab::FsLine', 'type' => 'node' }, 'description' => 'Each "fs" element contain the information about one filesystem. Each filesystem is referred in this model by a label constructed by the fstab parser. This label cannot be stored in the fstab file, so if you create a new file system, the label you will choose may not be stored and will be re-created by the fstab parser', 'index_type' => 'string', 'summary' => 'specification of one file system', 'type' => 'hash' } ], 'license' => 'LGPL2', 'name' => 'Fstab', 'read_config' => [ { 'backend' => 'Fstab', 'config_dir' => '/etc', 'file' => 'fstab' } ] } ] ; Config-Model-2.097/lib/Config/Model/models/Multistrap.pod0000644000175000017500000000563013027007223021606 0ustar domidomi# PODNAME: Config::Model::models::Multistrap # ABSTRACT: Configuration class Multistrap =encoding utf8 =head1 NAME Config::Model::models::Multistrap - Configuration class Multistrap =head1 DESCRIPTION Configuration classes used by L Class for multistrap configuration files. Note that multistrap is based on INI where section and keys are case insensitive. Hence all sections and keys are converted to lower case and written back as lower case. Most values (but not all) are also case-insensitive. These values will also be written back as lowercase. =head1 Elements =head2 include - Include file for cascaded configuration To support multiple variants of a basic (common) configuration, "multistrap" allows configuration files to include other (more general) configuration files. i.e. the most detailed / specific configuration file is specified on the command line and that file includes another file which is shared by other configurations. I<< Optional. Type uniline. >> =head2 arch I<< Optional. Type enum. choice: 'alpha', 'arm', 'armel', 'powerpc'. >> =head2 directory - target directory top level directory where the bootstrap will be created. I<< Optional. Type uniline. >> =head2 aptsources aptsources is a list of sections to be used in the /etc/apt/sources.list.d/multistrap.sources.list of the target. Order is not important. I<< Optional. Type list of reference. >> =head2 bootstrap the bootstrap option determines which repository is used to calculate the list of Priority: required packages and which packages go into the rootfs. The order of sections is not important. I<< Optional. Type list of reference. >> =head2 debootstrap Replaced by bootstrap parameter. B I<< Optional. Type list of reference. >> =head2 omitrequired I<< Optional. Type boolean. >> =head2 addimportant I<< Optional. Type boolean. >> =head2 configscript I<< Optional. Type uniline. >> =head2 setupscript I<< Optional. Type uniline. >> =head2 cleanup remove apt cache data, downloaded Packages files and the apt package cache. I<< Optional. Type boolean. >> =head2 noauth allow the use of unauthenticated repositories. I<< Optional. Type boolean. >> =head2 explicitsuite whether to add the /suite to be explicit about where apt needs to look for packages. I<< Optional. Type boolean. upstream_default: '0'. >> =head2 unpack - extract all downloaded archives I<< Optional. Type boolean. upstream_default: '1'. >> Note: unpack is migrated with 'C<$old>' and with $old => "C<- forceunpack>" =head2 sections I<< Optional. Type hash of node of class L . >> =head2 forceunpack - extract all downloaded archives deprecated. Replaced by unpack. B I<< Optional. Type boolean. upstream_default: '1'. >> =head1 SEE ALSO =over =item * L =item * L =back =cut Config-Model-2.097/lib/Config/Model/models/Multistrap/0000755000175000017500000000000013027007223021076 5ustar domidomiConfig-Model-2.097/lib/Config/Model/models/Multistrap/Section.pl0000644000175000017500000000222013027007223023033 0ustar domidomi# # This file is part of Config-Model # # This software is Copyright (c) 2005-2016 by Dominique Dumont. # # This is free software, licensed under: # # The GNU Lesser General Public License, Version 2.1, February 1999 # [ { 'accept' => [ '\\w+', { 'type' => 'leaf', 'value_type' => 'uniline', 'warn' => 'Handling unknown parameter as unlinie value.' } ], 'element' => [ 'packages', { 'cargo' => { 'type' => 'leaf', 'value_type' => 'uniline' }, 'type' => 'list' }, 'components', { 'cargo' => { 'type' => 'leaf', 'value_type' => 'uniline' }, 'type' => 'list' }, 'source', { 'type' => 'leaf', 'value_type' => 'uniline' }, 'keyring', { 'type' => 'leaf', 'value_type' => 'uniline' }, 'suite', { 'type' => 'leaf', 'value_type' => 'uniline' }, 'omitdebsrc', { 'type' => 'leaf', 'value_type' => 'boolean' } ], 'name' => 'Multistrap::Section' } ] ; Config-Model-2.097/lib/Config/Model/models/Multistrap/Section.pod0000644000175000017500000000125113027007223023205 0ustar domidomi# PODNAME: Config::Model::models::Multistrap::Section # ABSTRACT: Configuration class Multistrap::Section =encoding utf8 =head1 NAME Config::Model::models::Multistrap::Section - Configuration class Multistrap::Section =head1 DESCRIPTION Configuration classes used by L =head1 Elements =head2 packages I<< Optional. Type list of uniline. >> =head2 components I<< Optional. Type list of uniline. >> =head2 source I<< Optional. Type uniline. >> =head2 keyring I<< Optional. Type uniline. >> =head2 suite I<< Optional. Type uniline. >> =head2 omitdebsrc I<< Optional. Type boolean. >> =head1 SEE ALSO =over =item * L =back =cut Config-Model-2.097/lib/Config/Model/models/Fstab.pod0000644000175000017500000000212213027007223020472 0ustar domidomi# PODNAME: Config::Model::models::Fstab # ABSTRACT: Configuration class Fstab =encoding utf8 =head1 NAME Config::Model::models::Fstab - Configuration class Fstab =head1 DESCRIPTION Configuration classes used by L static information about the filesystems. fstab contains descriptive information about the various file systems. =head1 Elements =head2 fs - specification of one file system Each "fs" element contain the information about one filesystem. Each filesystem is referred in this model by a label constructed by the fstab parser. This label cannot be stored in the fstab file, so if you create a new file system, the label you will choose may not be stored and will be re-created by the fstab parser. I<< Optional. Type hash of node of class L . >> =head1 SEE ALSO =over =item * L =item * L =back =head1 AUTHOR =over =item Dominique Dumont =back =head1 COPYRIGHT =over =item 2010,2011 Dominique Dumont =back =head1 LICENSE =over =item LGPL2 =back =cut Config-Model-2.097/lib/Config/Model/models/Fstab/0000755000175000017500000000000013027007223017771 5ustar domidomiConfig-Model-2.097/lib/Config/Model/models/Fstab/FsLine.pod0000644000175000017500000000362413027007223021662 0ustar domidomi# PODNAME: Config::Model::models::Fstab::FsLine # ABSTRACT: Configuration class Fstab::FsLine =encoding utf8 =head1 NAME Config::Model::models::Fstab::FsLine - Configuration class Fstab::FsLine =head1 DESCRIPTION Configuration classes used by L data of one /etc/fstab line =head1 Elements =head2 fs_spec block special device or remote filesystem to be mounted. I<< Mandatory. Type uniline. >> =head2 fs_file mount point for the filesystem. I<< Mandatory. Type uniline. >> =head2 fs_vfstype file system type. I<< Mandatory. Type enum. choice: 'auto', 'davfs', 'ext2', 'ext3', 'ext4', 'swap', 'proc', 'iso9660', 'vfat', 'usbfs', 'ignore', 'nfs', 'nfs4', 'none', 'ignore', 'debugfs'. >> Here are some explanations on the possible values: =over =item 'auto' file system type is probed by the kernel when mounting the device =item 'davfs' WebDav access =item 'ext2' Common Linux file system. =item 'ext3' Common Linux file system with journaling =item 'ignore' unused disk partition =item 'iso9660' CD-ROM or DVD file system =item 'proc' Kernel info through a special file system =item 'usbfs' USB pseudo file system. Gives a file system view of kernel data related to usb =item 'vfat' Older Windows file system often used on removable media =back =head2 fs_mntopts mount options associated with the filesystem. I<< Optional. Type warped_node. >> =head2 fs_freq Specifies if the file system needs to be dumped. I<< Optional. Type enum. choice: '0', '1'. default: '0'. >> =head2 fs_passno - fsck pass number used by the fsck(8) program to determine the order in which filesystem checks are done at reboot time. I<< Optional. Type integer. default: '0'. >> =head1 SEE ALSO =over =item * L =back =head1 AUTHOR =over =item Dominique Dumont =back =head1 COPYRIGHT =over =item 2010,2011 Dominique Dumont =back =head1 LICENSE =over =item LGPL2 =back =cut Config-Model-2.097/lib/Config/Model/models/Fstab/Ext4FsOpt.pl0000644000175000017500000000164213027007223022131 0ustar domidomi# # This file is part of Config-Model # # This software is Copyright (c) 2005-2016 by Dominique Dumont. # # This is free software, licensed under: # # The GNU Lesser General Public License, Version 2.1, February 1999 # [ { 'author' => [ 'Dominique Dumont' ], 'copyright' => [ '2010,2011 Dominique Dumont' ], 'element' => [ 'lazy_itable_init', { 'description' => 'If enabled and the uninit_bg feature is enabled, the inode table will not be fully initialized by mke2fs. This speeds up filesystem initialization noticeably, but it requires the kernel to finish initializing the filesystem in the background when the filesystem is first mounted.', 'type' => 'leaf', 'upstream_default' => '1', 'value_type' => 'boolean' } ], 'include' => [ 'Fstab::Ext2FsOpt' ], 'license' => 'LGPL2', 'name' => 'Fstab::Ext4FsOpt' } ] ; Config-Model-2.097/lib/Config/Model/models/Fstab/NoneOptions.pl0000644000175000017500000000113213027007223022576 0ustar domidomi# # This file is part of Config-Model # # This software is Copyright (c) 2005-2016 by Dominique Dumont. # # This is free software, licensed under: # # The GNU Lesser General Public License, Version 2.1, February 1999 # [ { 'author' => [ 'Dominique Dumont' ], 'class_description' => 'Options for special file system like \'bind\'', 'copyright' => [ '2010,2011 Dominique Dumont' ], 'element' => [ 'bind', { 'type' => 'leaf', 'value_type' => 'boolean' } ], 'license' => 'LGPL2', 'name' => 'Fstab::NoneOptions' } ] ; Config-Model-2.097/lib/Config/Model/models/Fstab/SwapOptions.pl0000644000175000017500000000106713027007223022620 0ustar domidomi# # This file is part of Config-Model # # This software is Copyright (c) 2005-2016 by Dominique Dumont. # # This is free software, licensed under: # # The GNU Lesser General Public License, Version 2.1, February 1999 # [ { 'author' => [ 'Dominique Dumont' ], 'class_description' => 'Swap options', 'copyright' => [ '2010,2011 Dominique Dumont' ], 'element' => [ 'sw', { 'type' => 'leaf', 'value_type' => 'boolean' } ], 'license' => 'LGPL2', 'name' => 'Fstab::SwapOptions' } ] ; Config-Model-2.097/lib/Config/Model/models/Fstab/Ext3FsOpt.pl0000644000175000017500000000325013027007223022125 0ustar domidomi# # This file is part of Config-Model # # This software is Copyright (c) 2005-2016 by Dominique Dumont. # # This is free software, licensed under: # # The GNU Lesser General Public License, Version 2.1, February 1999 # [ { 'author' => [ 'Dominique Dumont' ], 'class_description' => 'Options for ext4 file systems. Please contact author (domi.dumont at cpan.org) if options are missing.', 'copyright' => [ '2010,2011 Dominique Dumont' ], 'element' => [ 'journalling_mode', { 'choice' => [ 'journal', 'ordered', 'writeback' ], 'description' => 'Specifies the journalling mode for file data. Metadata is always journaled. To use modes other than ordered on the root file system, pass the mode to the kernel as boot parameter, e.g. rootflags=data=journal.', 'help' => { 'journal' => 'All data is committed into the journal prior to being written into the main file system. ', 'ordered' => 'This is the default mode. All data is forced directly out to the main file system prior to its metadata being committed to the journal.', 'writeback' => 'Data ordering is not preserved - data may be writteninto the main file system after its metadata has been committed to the journal. This is rumoured to be the highest-throughput option. It guarantees internal file system integrity, however it can allow old data to appear in files after a crash and journal recovery.' }, 'type' => 'leaf', 'value_type' => 'enum' } ], 'include' => [ 'Fstab::Ext2FsOpt' ], 'license' => 'LGPL2', 'name' => 'Fstab::Ext3FsOpt' } ] ; Config-Model-2.097/lib/Config/Model/models/Fstab/FsLine.pl0000644000175000017500000001301513027007223021506 0ustar domidomi# # This file is part of Config-Model # # This software is Copyright (c) 2005-2016 by Dominique Dumont. # # This is free software, licensed under: # # The GNU Lesser General Public License, Version 2.1, February 1999 # [ { 'author' => [ 'Dominique Dumont' ], 'class_description' => 'data of one /etc/fstab line', 'copyright' => [ '2010,2011 Dominique Dumont' ], 'element' => [ 'fs_spec', { 'description' => 'block special device or remote filesystem to be mounted', 'mandatory' => 1, 'type' => 'leaf', 'value_type' => 'uniline', 'warp' => { 'follow' => { 'f1' => '- fs_vfstype' }, 'rules' => [ '$f1 eq \'proc\'', { 'default' => 'proc' } ] } }, 'fs_file', { 'description' => 'mount point for the filesystem', 'mandatory' => 1, 'type' => 'leaf', 'value_type' => 'uniline', 'warp' => { 'follow' => { 'f1' => '- fs_vfstype' }, 'rules' => [ '$f1 eq \'proc\'', { 'default' => '/proc' }, '$f1 eq \'swap\'', { 'default' => 'none' } ] } }, 'fs_vfstype', { 'choice' => [ 'auto', 'davfs', 'ext2', 'ext3', 'ext4', 'swap', 'proc', 'iso9660', 'vfat', 'usbfs', 'ignore', 'nfs', 'nfs4', 'none', 'ignore', 'debugfs' ], 'description' => 'file system type', 'help' => { 'auto' => 'file system type is probed by the kernel when mounting the device', 'davfs' => 'WebDav access', 'ext2' => 'Common Linux file system.', 'ext3' => 'Common Linux file system with journaling ', 'ignore' => 'unused disk partition', 'iso9660' => 'CD-ROM or DVD file system', 'proc' => 'Kernel info through a special file system', 'usbfs' => 'USB pseudo file system. Gives a file system view of kernel data related to usb', 'vfat' => 'Older Windows file system often used on removable media' }, 'mandatory' => 1, 'type' => 'leaf', 'value_type' => 'enum' }, 'fs_mntopts', { 'description' => 'mount options associated with the filesystem', 'type' => 'warped_node', 'warp' => { 'follow' => { 'f1' => '- fs_vfstype' }, 'rules' => [ '$f1 eq \'proc\'', { 'config_class_name' => 'Fstab::CommonOptions' }, '$f1 eq \'auto\'', { 'config_class_name' => 'Fstab::CommonOptions' }, '$f1 eq \'vfat\'', { 'config_class_name' => 'Fstab::CommonOptions' }, '$f1 eq \'swap\'', { 'config_class_name' => 'Fstab::SwapOptions' }, '$f1 eq \'ext2\'', { 'config_class_name' => 'Fstab::Ext2FsOpt' }, '$f1 eq \'ext3\'', { 'config_class_name' => 'Fstab::Ext3FsOpt' }, '$f1 eq \'ext4\'', { 'config_class_name' => 'Fstab::Ext4FsOpt' }, '$f1 eq \'usbfs\'', { 'config_class_name' => 'Fstab::UsbFsOptions' }, '$f1 eq \'davfs\'', { 'config_class_name' => 'Fstab::CommonOptions' }, '$f1 eq \'iso9660\'', { 'config_class_name' => 'Fstab::Iso9660_Opt' }, '$f1 eq \'nfs\'', { 'config_class_name' => 'Fstab::CommonOptions' }, '$f1 eq \'nfs4\'', { 'config_class_name' => 'Fstab::CommonOptions' }, '$f1 eq \'none\'', { 'config_class_name' => 'Fstab::NoneOptions' }, '$f1 eq \'debugfs\'', { 'config_class_name' => 'Fstab::CommonOptions' } ] } }, 'fs_freq', { 'choice' => [ '0', '1' ], 'default' => '0', 'description' => 'Specifies if the file system needs to be dumped', 'type' => 'leaf', 'value_type' => 'enum', 'warp' => { 'follow' => { 'fstyp' => '- fs_vfstype', 'isbound' => '- fs_mntopts bind' }, 'rules' => [ '$fstyp eq "none" and $isbound', { 'choice' => [ '0' ] } ] } }, 'fs_passno', { 'default' => 0, 'description' => 'used by the fsck(8) program to determine the order in which filesystem checks are done at reboot time', 'summary' => 'fsck pass number', 'type' => 'leaf', 'value_type' => 'integer', 'warp' => { 'follow' => { 'fstyp' => '- fs_vfstype', 'isbound' => '- fs_mntopts bind' }, 'rules' => [ '$fstyp eq "none" and $isbound', { 'max' => '0' } ] } } ], 'license' => 'LGPL2', 'name' => 'Fstab::FsLine' } ] ; Config-Model-2.097/lib/Config/Model/models/Fstab/Ext2FsOpt.pl0000644000175000017500000000235113027007223022125 0ustar domidomi# # This file is part of Config-Model # # This software is Copyright (c) 2005-2016 by Dominique Dumont. # # This is free software, licensed under: # # The GNU Lesser General Public License, Version 2.1, February 1999 # [ { 'accept' => [ '.*', { 'description' => 'unknown parameter', 'type' => 'leaf', 'value_type' => 'uniline' } ], 'author' => [ 'Dominique Dumont' ], 'copyright' => [ '2010,2011 Dominique Dumont' ], 'element' => [ 'acl', { 'type' => 'leaf', 'value_type' => 'boolean' }, 'user_xattr', { 'description' => 'Support "user." extended attributes ', 'type' => 'leaf', 'value_type' => 'boolean' }, 'statfs_behavior', { 'choice' => [ 'bsddf', 'minixdf' ], 'type' => 'leaf', 'value_type' => 'enum' }, 'errors', { 'choice' => [ 'continue', 'remount-ro', 'panic' ], 'type' => 'leaf', 'value_type' => 'enum' } ], 'include' => [ 'Fstab::CommonOptions' ], 'license' => 'LGPL2', 'name' => 'Fstab::Ext2FsOpt' } ] ; Config-Model-2.097/lib/Config/Model/models/Fstab/UsbFsOptions.pl0000644000175000017500000000324613027007223022731 0ustar domidomi# # This file is part of Config-Model # # This software is Copyright (c) 2005-2016 by Dominique Dumont. # # This is free software, licensed under: # # The GNU Lesser General Public License, Version 2.1, February 1999 # [ { 'author' => [ 'Dominique Dumont' ], 'class_description' => 'usbfs options', 'copyright' => [ '2010,2011 Dominique Dumont' ], 'element' => [ 'devuid', { 'type' => 'leaf', 'upstream_default' => '0', 'value_type' => 'integer' }, 'devgid', { 'type' => 'leaf', 'upstream_default' => '0', 'value_type' => 'integer' }, 'busuid', { 'type' => 'leaf', 'upstream_default' => '0', 'value_type' => 'integer' }, 'budgid', { 'type' => 'leaf', 'upstream_default' => '0', 'value_type' => 'integer' }, 'listuid', { 'type' => 'leaf', 'upstream_default' => '0', 'value_type' => 'integer' }, 'listgid', { 'type' => 'leaf', 'upstream_default' => '0', 'value_type' => 'integer' }, 'devmode', { 'type' => 'leaf', 'upstream_default' => '0644', 'value_type' => 'integer' }, 'busmode', { 'type' => 'leaf', 'upstream_default' => '0555', 'value_type' => 'integer' }, 'listmode', { 'type' => 'leaf', 'upstream_default' => '0444', 'value_type' => 'integer' } ], 'include' => [ 'Fstab::CommonOptions' ], 'license' => 'LGPL2', 'name' => 'Fstab::UsbFsOptions' } ] ; Config-Model-2.097/lib/Config/Model/models/Fstab/CommonOptions.pl0000644000175000017500000000346613027007223023143 0ustar domidomi# # This file is part of Config-Model # # This software is Copyright (c) 2005-2016 by Dominique Dumont. # # This is free software, licensed under: # # The GNU Lesser General Public License, Version 2.1, February 1999 # [ { 'author' => [ 'Dominique Dumont' ], 'class_description' => 'options valid for all types of file systems.', 'copyright' => [ '2010,2011 Dominique Dumont' ], 'element' => [ 'async', { 'type' => 'leaf', 'value_type' => 'boolean' }, 'atime', { 'type' => 'leaf', 'value_type' => 'boolean' }, 'auto', { 'type' => 'leaf', 'value_type' => 'boolean' }, 'dev', { 'type' => 'leaf', 'value_type' => 'boolean' }, 'exec', { 'type' => 'leaf', 'value_type' => 'boolean' }, 'group', { 'type' => 'leaf', 'value_type' => 'boolean' }, 'mand', { 'type' => 'leaf', 'value_type' => 'boolean' }, 'user', { 'help' => { '0' => 'Only root can mount the file system', '1' => 'user can mount the file system' }, 'type' => 'leaf', 'value_type' => 'boolean' }, 'defaults', { 'help' => { '1' => 'option equivalent to rw, suid, dev, exec, auto, nouser, and async' }, 'type' => 'leaf', 'value_type' => 'boolean' }, 'rw', { 'help' => { '0' => 'read-only file system' }, 'type' => 'leaf', 'value_type' => 'boolean' }, 'relatime', { 'type' => 'leaf', 'value_type' => 'boolean' } ], 'license' => 'LGPL2', 'name' => 'Fstab::CommonOptions' } ] ; Config-Model-2.097/lib/Config/Model/models/Fstab/Iso9660_Opt.pl0000644000175000017500000000124213027007223022226 0ustar domidomi# # This file is part of Config-Model # # This software is Copyright (c) 2005-2016 by Dominique Dumont. # # This is free software, licensed under: # # The GNU Lesser General Public License, Version 2.1, February 1999 # [ { 'author' => [ 'Dominique Dumont' ], 'copyright' => [ '2010,2011 Dominique Dumont' ], 'element' => [ 'rock', { 'type' => 'leaf', 'value_type' => 'boolean' }, 'joliet', { 'type' => 'leaf', 'value_type' => 'boolean' } ], 'include' => [ 'Fstab::CommonOptions' ], 'license' => 'LGPL2', 'name' => 'Fstab::Iso9660_Opt' } ] ; Config-Model-2.097/lib/Config/Model/Annotation.pm0000644000175000017500000001540313027007223020122 0ustar domidomi# # This file is part of Config-Model # # This software is Copyright (c) 2005-2016 by Dominique Dumont. # # This is free software, licensed under: # # The GNU Lesser General Public License, Version 2.1, February 1999 # package Config::Model::Annotation; $Config::Model::Annotation::VERSION = '2.097'; use Mouse; use English; use File::Path; use IO::File; use Data::Dumper; use Config::Model::Exception; use Config::Model::Node; use Config::Model::ObjTreeScanner; use strict ; use warnings; use Carp qw/croak confess cluck/; #my $logger = get_logger("Annotation") ; has 'instance' => ( is => 'ro', isa => 'Config::Model::Instance', required => 1 ); has 'config_class_name' => ( is => 'ro', isa => 'Str', required => 1 ); has 'file' => ( is => 'ro', isa => 'Str', lazy => 1, builder => '_set_file' ); has 'dir' => ( is => 'ro', isa => 'Str', lazy => 1, builder => '_set_dir' ); has 'root_dir' => ( is => 'ro', isa => 'Str|Undef', default => '' ); sub _set_file { my $self = shift; return $self->dir . $self->config_class_name . '-note.pl'; } sub _set_dir { my $self = shift; my $dir = $self->root_dir ? $self->root_dir : $EUID ? "/var/lib/" : "~/."; $dir .= "config-model/"; return $dir; } sub save { my $self = shift; my $dir = $self->dir; mkpath( $dir, { mode => 0755, verbose => 0 } ) unless -d $dir; my $h = $self->get_annotation_hash; my $data = Dumper($h); my $io = IO::File->new( $self->file, 'w', 0644 ) || croak "Can't open $dir" . $self->file . ": $!"; print $io $data; $io->close; } sub get_annotation_hash { my $self = shift; my %data; my $scanner = Config::Model::ObjTreeScanner->new( leaf_cb => \&my_leaf_cb, hash_element_cb => \&my_hash_element_cb, list_element_cb => \&my_list_element_cb, node_element_cb => \&my_node_element_cb, fallback => 'all', ); my $root = $self->instance->config_root; $scanner->scan_node( \%data, $root ); return \%data; } # WARNING: not a method sub my_hash_element_cb { my ( $scanner, $data_ref, $node, $element_name, @keys ) = @_; # custom code using $data_ref store_note_in_data( $data_ref, $node->fetch_element($element_name) ); # resume exploration map { $scanner->scan_hash( $data_ref, $node, $element_name, $_ ) } @keys; } # WARNING: not a method sub my_node_element_cb { my ( $scanner, $data_ref, $node, $element_name, $key, $contained_node ) = @_; # your custom code using $data_ref store_note_in_data( $data_ref, $contained_node ); # explore next node $scanner->scan_node( $data_ref, $contained_node ); } # WARNING: not a method sub my_list_element_cb { my ( $scanner, $data_ref, $node, $element_name, @idx ) = @_; # custom code using $data_ref store_note_in_data( $data_ref, $node->fetch_element($element_name) ); # resume exploration (if needed) map { $scanner->scan_list( $data_ref, $node, $element_name, $_ ) } @idx; # note: scan_list and scan_hash are equivalent } # WARNING: not a method sub my_leaf_cb { my ( $scanner, $data_ref, $node, $element_name, $index, $leaf_object ) = @_; store_note_in_data( $data_ref, $leaf_object ); } # WARNING: not a method sub store_note_in_data { my ( $data_ref, $obj ) = @_; my $note = $obj->annotation; return unless $note; my $key = $obj->location; $data_ref->{$key} = $note; } sub load { my $self = shift; my $f = $self->file; return unless -e $f; my $hash = do "./$f" || croak "can't do $f:$!"; my $root = $self->instance->config_root; foreach my $path ( keys %$hash ) { my $obj = eval { $root->grab( step => $path, autoadd => 0 ) }; next if $@; # skip annotation of unknown elements $obj->annotation( $hash->{$path} ); } } no Mouse; __PACKAGE__->meta->make_immutable; 1; # ABSTRACT: Read and write configuration annotations __END__ =pod =encoding UTF-8 =head1 NAME Config::Model::Annotation - Read and write configuration annotations =head1 VERSION version 2.097 =head1 SYNOPSIS use Config::Model ; # define configuration tree object my $model = Config::Model->new ; $model ->create_config_class ( name => "MyClass", element => [ [qw/foo bar/] => { type => 'leaf', value_type => 'string' }, baz => { type => 'hash', index_type => 'string' , cargo => { type => 'leaf', value_type => 'string', }, }, ], ) ; my $inst = $model->instance(root_class_name => 'MyClass' ); my $root = $inst->config_root ; # put some data in config tree the hard way $root->fetch_element('foo')->store('yada') ; $root->fetch_element('baz')->fetch_with_id('en')->store('hello') ; # put annotation the hard way $root->fetch_element('foo')->annotation('english') ; $root->fetch_element('baz')->fetch_with_id('en')->annotation('also english') ; # put more data the easy way my $steps = 'baz:fr=bonjour#french baz:hr="dobar dan"#croatian'; $root->load( steps => $steps ) ; # dump resulting tree with annotations print $root->dump_tree; # save annotations my $annotate_saver = Config::Model::Annotation -> new ( config_class_name => 'MyClass', instance => $inst , root_dir => '/tmp/', # for test ) ; $annotate_saver->save ; # now check content of /tmp/config-model/MyClass-note.pl =head1 DESCRIPTION This module provides an object that read and write annotations (a bit like comments) to and from a configuration tree and save them in a file (not configuration file). This module can be used to save annotation for configuration files that do not support comments. THis module should not be used for configuration files that support comments. Depending on the effective id of the process, the annotation is saved in: =over =item * C<< /var/lib/config-model/-note.yml >> for root (EUID == 0) =item * C<< ~/.config-model/-note.yml >> for normal user (EUID > 0) =back =head1 CONSTRUCTOR Quite standard. The constructor is passed a L object. =head1 METHODS =head2 save() Save annotations in a file (See L) =head2 load() Loads annotations from a file (See L) =head1 CAVEATS This module is currently not used. =head1 AUTHOR Dominique Dumont, (ddumont at cpan dot org) =head1 SEE ALSO L, L, L, L, L, =head1 AUTHOR Dominique Dumont =head1 COPYRIGHT AND LICENSE This software is Copyright (c) 2005-2016 by Dominique Dumont. This is free software, licensed under: The GNU Lesser General Public License, Version 2.1, February 1999 =cut Config-Model-2.097/lib/Config/Model/SearchElement.pm0000644000175000017500000003531413027007223020532 0ustar domidomi# # This file is part of Config-Model # # This software is Copyright (c) 2005-2016 by Dominique Dumont. # # This is free software, licensed under: # # The GNU Lesser General Public License, Version 2.1, February 1999 # package Config::Model::SearchElement; $Config::Model::SearchElement::VERSION = '2.097'; use Log::Log4perl qw(get_logger :levels); use Carp; use strict; use warnings; use Config::Model::Exception; my $logger = get_logger("Model::Searcher"); sub new { my $type = shift; my %args = @_; my $self = {}; foreach my $p (qw/model node/) { $self->{$p} = delete $args{$p} or croak "Searcher->new: Missing $p parameter"; } bless $self, $type; $self->{privilege} = $args{privilege} || 'master'; my $root_class = $self->{node}->config_class_name; $self->{data} = $self->_sniff_class( $root_class, $self->{privilege}, {} ); return $self; } # to verify the data structure returned by search_element, you can used # either Data::Dumper or Tk::ObjScanner (both are available on CPAN) sub _sniff_class { my ( $self, $class, $privilege, $found_ref ) = @_; my @lines; my %h; my $model = $self->{model}; my $c_model = $model->get_model($class); $logger->debug("sniffing config class $class"); croak "Recursive config class $class detected, aborting..." if defined $found_ref->{$class}; $found_ref->{$class} = 1; my @elements = $model->get_element_name( class => $class, ); foreach my $element (@elements) { my $element_model = $c_model->{element}{$element}; my $element_type = $element_model->{type}; my $cargo = $element_model->{cargo}; my $c_type = defined $cargo ? $cargo->{type} : ''; my $cfg_class_name = defined $cargo ? $cargo->{config_class_name} : $element_model->{config_class_name}; my %local_found = %$found_ref; if ( $element_type =~ /(warped_)?node/ or $c_type =~ /(warped_)?node/ ) { my $tmp = $element_type eq 'node' || $c_type eq 'node' ? $self->_sniff_class( $cfg_class_name, $privilege, \%local_found ) : $self->_sniff_warped_node( $element_model, $privilege, \%local_found ); # merge all tmp in %h map { $h{$_}{next_step}{$element} = $tmp->{$_}; } keys %$tmp; } else { $h{$element}{next_step}{$element} = ''; } } $logger->debug("done sniffing config class $class"); return \%h; } sub _sniff_warped_node { my ( $self, $element_model, $privilege, $found_ref ) = @_; my %warp_tmp; my $ref = $element_model->{warp}{rules}; my @rules = ref $ref eq 'HASH' ? %$ref : @$ref; for ( my $r_idx = 0 ; $r_idx < $#rules ; $r_idx += 2 ) { my $res = $rules[ $r_idx + 1 ]{config_class_name}; my $sub_class = ref $res ? $res->[0] : $res; # sniff all classes mentionned in warped node rules my %local_found = %$found_ref; my $tmp = $self->_sniff_class( $sub_class, $privilege, \%local_found ); # merge all tmp in %warp_tmp map { $warp_tmp{$_}{next_class}{$sub_class} = $tmp->{$_}; } keys %$tmp; } return \%warp_tmp; } sub get_searchable_elements { my $self = shift; sort keys %{ $self->{data} }; } sub prepare { my $self = shift; my %args = @_; foreach my $p (qw/element/) { $self->{$p} = delete $args{$p} or croak "Searcher->prepare: Missing $p parameter"; } $self->reset; # initialize the search engine unless ( defined $self->{search_tree} ) { my $searched = $self->{element}; my $root_class = $self->{node}->config_class_name; Config::Model::Exception::User->throw( message => "Searcher cannot find element '$searched' " . "from $root_class. Found only " . join( ' ', sort keys %{ $self->{data} } ) ); } return $self; } sub reset { my $self = shift; my $searched = $self->{element}; $self->{search_tree} = $self->{data}{$searched}; $self->{current}{object} = $self->{node}; $self->{current}{element_name} = 'Root'; $self->{current}{element_type} = 'node'; } sub searched { return shift->{element}; } sub next_step { my $self = shift; my $current_obj = $self->{current}{object}; my @result; if ( $current_obj->get_type =~ /list|hash/ ) { @result = $current_obj->fetch_all_indexes; } else { my $next_step = $self->{search_tree}{next_step}; @result = ref $next_step ? sort keys %$next_step : defined $next_step ? die "next_step error" : (); } #my $name = $self->{current}{element_name} ; #print "From $name, next_step is @result\n"; return wantarray ? @result : \@result; } sub next_choice { my $self = shift; my $result; while (1) { $result = $self->next_step; $logger->debug("next_choice: result is @$result"); return $result if scalar @$result != 1; $self->choose(@$result); } } # TBD if choice is an id, Node is a hash... sub choose { my $self = shift; my $choice = shift; #print "choose $choice from node\n"; my $obj = $self->{current}{object}; if ( $obj->get_type =~ /hash|list/ ) { $self->choose_from_id_element($choice); } else { $self->choose_from_node($choice); } } sub choose_from_id_element { my $self = shift; my $choice = shift; #print "choose $choice from id\n"; my $id_obj = $self->{current}{object}; my $class = $id_obj->config_class_name; # the following line may trigger an exception for warped out # elements my $next_node = $id_obj->fetch_with_id($choice); $self->{current}{object} = $next_node; return $next_node; } sub choose_from_node { my $self = shift; my $choice = shift; #print "choose $choice from node\n"; my $next = $self->{search_tree}{next_step}; my $node = $self->{current}{object}; my $node_class = $node->config_class_name; if ( ref($next) and not defined $next->{$choice} ) { Config::Model::Exception::User->throw( message => "Searcher: wrong choice '$choice' " . "from $node_class. expected " . join( ' ', sort keys %$next ) ); } # the following line may trigger an exception for warped out # elements my $next_node = $node->fetch_element($choice); # $next is a scalar for leaf element of a ref for node element if ( $next->{$choice} ) { my $data = $next->{$choice}; # gobble next_class for warped_node element if ( defined $data->{next_class} ) { my $chosen_class = $next_node->config_class_name; $data = $data->{next_class}{$chosen_class}; unless ( defined $data ) { Config::Model::Exception::User->throw( message => "Searcher: choice '$choice' " . "from $node_class leads to a warped out node: " . $next_node->warp_error ); } } $self->{search_tree} = $data; } else { $self->{search_tree} = { next_step => undef }; $next_node = $node->fetch_element($choice); } $self->{current}{object} = $next_node; $self->{current}{element_type} = $node->element_type($choice); $self->{current}{element_name} = $choice; return $next_node; } sub current_object { my $self = shift; return $self->{current}{object}; } sub auto_choose { my $self = shift; my $elt_cb = shift || croak "auto_choose: missing element call back"; my $id_cb = shift || croak "auto_choose: missing id call back"; my $object = $self->{current}{object}; while (1) { my $next_step = $self->next_step; if ( scalar @$next_step == 0 ) { # found target return $self->{current}{object}; } my $next_choice = ( scalar @$next_step == 1 ) ? $next_step->[0] : $elt_cb->( $object, @$next_step ); $self->_auto_choose_elt( $next_choice, $id_cb ); } } sub _auto_choose_elt { my $self = shift; my $next_choice = shift; my $id_cb = shift; $self->choose($next_choice); my $elt_type = $self->{current}{element_type}; if ( $elt_type =~ /list|hash/ ) { my $object = $self->{current}{object}; my @choice = $object->fetch_all_indexes(); my $id = @choice == 1 ? $choice[0] : $id_cb->( $object, @choice ); $self->{current}{object} = $object->fetch_with_id($id); } } 1; # ABSTRACT: Search an element in a configuration model __END__ =pod =encoding UTF-8 =head1 NAME Config::Model::SearchElement - Search an element in a configuration model =head1 VERSION version 2.097 =head1 SYNOPSIS use Config::Model; # define configuration tree object my $model = Config::Model->new; $model->create_config_class( name => "Foo", element => [ [qw/foo bar/] => { type => 'leaf', value_type => 'string' }, ] ); $model ->create_config_class ( name => "MyClass", element => [ [qw/foo bar/] => { type => 'leaf', value_type => 'string' }, hash_of_nodes => { type => 'hash', # hash id index_type => 'string', cargo => { type => 'node', config_class_name => 'Foo' }, }, ], ) ; my $inst = $model->instance(root_class_name => 'MyClass' ); my $root = $inst->config_root ; # put data my $step = 'foo=FOO hash_of_nodes:fr foo=bonjour - hash_of_nodes:en foo=hello '; $root->load( step => $step ); # create searcher for manual search my $searcher = $root->searcher(); # looking for foo element in the tree $searcher -> prepare (element => 'foo') ; my @next = $searcher->next_step() ; print "next possible steps: @next\n"; # next possible steps: foo hash_of_nodes # Looking for foo below hash_of_nodes $searcher->choose('hash_of_nodes') ; @next = $searcher->next_step() ; print "next possible steps: @next\n"; # next possible steps: en fr # Looking for foo below fr $searcher->choose('fr') ; @next = $searcher->next_step() ; print "next possible steps: @next\n"; # next possible steps: foo # last step $searcher->choose('foo') ; my $target = $searcher->current_object; print "Found '",$target->location,"'\n"; # Found 'hash_of_nodes:fr foo' # automatic search setup my $element_call_back = sub { return 'hash_of_nodes' ;} ; my $id_call_back = sub { return 'en' ;} ; $searcher->reset ; $target = $searcher->auto_choose($element_call_back, $id_call_back) ; print "Automatic search found '",$target->location,"'\n"; # Automatic search found 'hash_of_nodes:en foo' =head1 DESCRIPTION This modules provides a way to search for a configuration element in a configuration tree by exploring the configuration model. For instance, suppose that you have a xorg.conf model and you know that you need to tune the C parameter, but you don't remember where is this parameter in the configuration tree. This module guides you through the tree to the(s) node(s) that contain this parameter. This class should be invaluable to construct interactive user interfaces. This module provides 2 search modes: =over =item * A manual search where you are guided step by step to the element you're looking for. At each step, the module returns you the possible paths to choose from. The user has to choose the correct path from the available paths. Most of the time, only one possibility is returned, so the user choice should be straightforward. In other case (more that one choice), the user has to decide the next step. =item * An automatic search where you provide call-back that resolves the ambiguities in case of multiple paths. =back =head1 CONSTRUCTOR The constructor should be used only by L. =head1 Methods =head2 get_searchable_elements Return the list of elements found in model that can be searched in the configuration tree. =head2 prepare(element => ...) Prepare the searcher to look for the element passed in the argument. Returns the searcher object (i.e. $self). =head2 reset Re-initialize the search engine to redo the search from start =head2 searched Returns the searched element name. =head1 Manual search =head2 next_step() Returns an array (or a ref depending on context) containing the next possible step to find the element you're looking for. The array ref can contain 1 or more elements. If the array ref is empty, you can get the target element with L. =head2 next_choice() Returns an array ref containing the next non-obvious choice to find the element you're looking for. If the array ref is empty, you can get the target element with L. =head2 choose( ) Tell the search engine your choice. The chosen element name must be one of the possibilities given by L. =head2 current_object() Returns the object where the search engine is. It can be a L, a L, a L, or a L. =head1 Automatic search =head2 auto_choose ( element_callback, id_call_back) Finds the searched element with minimal user interaction. C is called when the search engine finds a node where more than one element can lead to the searched item. C is called when the search engine finds a hash element or a list element which contain B or B elements. In this case the call-back returns an id that is used by the search engine to get the target element. Both call-back arguments are: =over =item * The current object (as returned by L) =item * A list of possible choices =back For instance, your callback can be : my $id_cb = sub { my ($object,@choices) = @_ ; .... return $choice[1] ; } Both call-back are expected to return a scalar value that is either: =over =item * An element name =item * An id valid for the list or hash element returned by L. =back =head1 AUTHOR Dominique Dumont, (ddumont at cpan dot org) =head1 SEE ALSO L, L, L, L, L, L, =head1 AUTHOR Dominique Dumont =head1 COPYRIGHT AND LICENSE This software is Copyright (c) 2005-2016 by Dominique Dumont. This is free software, licensed under: The GNU Lesser General Public License, Version 2.1, February 1999 =cut Config-Model-2.097/lib/Config/Model/Loader.pm0000644000175000017500000010760513027007223017224 0ustar domidomi# # This file is part of Config-Model # # This software is Copyright (c) 2005-2016 by Dominique Dumont. # # This is free software, licensed under: # # The GNU Lesser General Public License, Version 2.1, February 1999 # package Config::Model::Loader; $Config::Model::Loader::VERSION = '2.097'; use Carp; use strict; use warnings; use 5.10.1; use Config::Model::Exception; use Log::Log4perl qw(get_logger :levels); my $logger = get_logger("Loader"); ## load stuff, similar to grab, but used to set items in the tree ## starting from this node sub new { bless {}, shift; } sub load { my $self = shift; my %args = @_; my $node = delete $args{node}; croak "load error: missing 'node' parameter" unless defined $node; my $steps = delete $args{steps} // delete $args{step}; croak "load error: missing 'steps' parameter" unless defined $steps; 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->debug("_load returned $ret"); # found '!' command if ( $ret eq 'root' ) { $logger->debug("Setting current_node to root node"); $current_node = $current_node->root; } } while ( $ret eq 'root' ); if (@command) { my $str = "Error: could not execute the required command, "; if ($command[0] =~ m!^/([\w-]+)!) { $str .= "the searched item '$1' was not found" ; } else { $str .= "you may have specified too many '-' in your command"; } Config::Model::Exception::Load->throw( command => $command[0], error => $str, object => $node ) if $check eq 'yes'; } if (%args) { Config::Model::Exception::Internal->throw( error => __PACKAGE__ . " load: unexpected parameters: " . join( ', ', keys %args ) ); } return $ret; } # returns elt action id subaction value sub _split_cmd { my $cmd = shift; $logger->debug("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 braces | ( /[^/]+/ # regexp | (?: $quoted_string | [^#=\.<>]+ # non action chars )+ ) )? )? (?: (=~|.=|[=<>]) # apply regexp or assign or append ( (?: $quoted_string | [^#\s] # or non whitespace )+ # many ) )? (?: \# # optional annotation ( (?: $quoted_string | [^\s] # or non whitespace )+ # many ) )? (.*) # 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->debug("_load: called on node $node_name"); my $inst = $node->instance; my $cmd; while ( $cmd = shift @$cmdref ) { if ( $logger->is_debug ) { my $msg = $cmd; $msg =~ s/\n/\\n/g; $logger->debug("_load: Executing cmd '$msg' on node $node_name"); } next if $cmd =~ /^\s*$/; if ( $cmd eq '!' ) { $logger->debug("_load: going to root, at_top_level is $at_top_level"); # Do not change current node as we don't want to mess up =~ commands return 'root'; } if ( $cmd eq '-' ) { $logger->debug("_load: going up"); return 'up'; } if ( $cmd =~ m!^/([\w-]+)! ) { my $search = $1; if ($node->has_element($search)) { $logger->debug("_load: search found node with element $search"); $cmd =~ s!^/!! ; } else { $logger->debug("_load: searching node with element $search, going up"); unshift @$cmdref, $cmd; return 'up'; } } my @instructions = _split_cmd($cmd); my ( $element_name, $action, $function_param, $id, $subaction, $value, $note ) = @instructions; if ( $logger->is_debug ) { my @disp = map { defined $_ ? "'$_'" : '' } @instructions; $logger->debug("_load instructions: @disp (left: $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 ) { $node->annotation($note); next; } unless ( $node->has_element($element_name) ) { Config::Model::Exception::UnknownElement->throw( object => $node, element => $element_name, ) if $check eq 'yes'; unshift @$cmdref, $cmd; return 'error'; } unless ( $node->is_element_available( name => $element_name ) ) { Config::Model::Exception::UnavailableElement->throw( object => $node, element => $element_name ) if $check eq 'yes'; unshift @$cmdref, $cmd; return 'error'; } unless ( $node->is_element_available( name => $element_name ) ) { Config::Model::Exception::RestrictedElement->throw( object => $node, element => $element_name, ) if $check eq 'yes'; unshift @$cmdref, $cmd; return 'error'; } my $element_type = $node->element_type($element_name); my $method = $load_dispatch{$element_type}; croak "_load: unexpected element type '$element_type' for $element_name" unless defined $method; $logger->debug("_load: calling $element_type loader on element $element_name"); my $ret = $self->$method( $node, $check, \@instructions, $cmdref ); $logger->debug("_load: $element_type loader on element $element_name returned $ret"); die "Internal error: method dispatched for $element_type returned an undefined value " unless defined $ret; if ( $ret eq 'error' or $ret eq 'done' ) { $logger->debug("_load return: $node_name got $ret"); return $ret; } if ( $ret eq 'root' and not $at_top_level ) { $logger->debug("_load return: $node_name got $ret"); return 'root'; } # ret eq up or ok -> go on with the loop } return 'done'; } sub _load_note { my ( $self, $target_obj, $note, $instructions, $cmdref ) = @_; unquote($note); # apply note on target object if ( defined $note ) { if ( defined $target_obj ) { $target_obj->annotation($note); } else { Config::Model::Exception::Load->throw( command => $$cmdref, error => "Error: cannot set annotation with '" . join( "','", grep { defined $_ } @$instructions ) . "'" ); } } } sub _walk_node { my ( $self, $node, $check, $inst, $cmdref ) = @_; my $element_name = shift @$inst; my $note = pop @$inst; my $element = $node->fetch_element($element_name); $self->_load_note( $element, $note, $inst, $cmdref ); my @left = grep { defined $_ } @$inst; if (@left) { Config::Model::Exception::Load->throw( command => $inst, error => "Don't know what to do with '@left' " . "for node element " . $element->element_name ); } $logger->info( "Opening node element ", $element->name ); return $self->_load( $element, $check, $cmdref ); } sub unquote { map { if (defined $_) { s/(?fetch_element( name => $element_name, check => $check ); if ( defined $note and not defined $action and not defined $subaction ) { $self->_load_note( $element, $note, $inst, $cmdref ); return 'ok'; } if ( defined $subaction and $subaction eq '=' ) { $logger->debug("_load_check_list: set whole list"); # valid for check_list or list $logger->info( "Setting check_list element ", $element->name, " with value ", $value ); $element->load( $value, check => $check ); $self->_load_note( $element, $note, $inst, $cmdref ); return 'ok'; } if ( not defined $action and defined $subaction ) { Config::Model::Exception::Load->throw( object => $element, command => join( '', grep ( defined $_, @$inst ) ), error => "Wrong assignment with '$subaction' on check_list" ); } my $a_str = defined $action ? $action : ''; Config::Model::Exception::Load->throw( object => $element, command => join( '', map { $_ || '' } @$inst ), error => "Wrong assignment with '$a_str' on check_list" ); } # sub is called with ( $self, $element, $check, $instance, @function_args ) # function_args are the arguments passed to the load command my %dispatch_action = ( list_leaf => { ':.sort' => sub { $_[1]->sort; 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'; }, ':@' => sub { $_[1]->sort; return 'ok'; }, ':.copy' => sub { $_[1]->copy( $_[5], $_[6] ); return 'ok'; }, ':.clear' => sub { $_[1]->clear; return 'ok';}, }, leaf => { ':-=' => \&_remove_by_value, ':-~' => \&_remove_matched_value, ':=~' => \&_substitute_value, }, fallback => { ':-' => \&_remove_by_id, '~' => \&_remove_by_id, } ); my @equiv = qw/:@ :.sort :< :.push :> :.unshift/; while (@equiv) { my ( $to, $from ) = splice @equiv, 0, 2; $dispatch_action{list_leaf}{$to} = $dispatch_action{list_leaf}{$from}; } sub _insert_before { my ( $self, $element, $check, $inst, $cmdref, $before_str, @values ) = @_; my $before = $before_str =~ m!^/! ? eval "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 _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 ) = @_; my ( $element_name, $action, $f_arg, $id, $subaction, $value, $note ) = @$inst; my $element = $node->fetch_element( name => $element_name, check => $check ); my @f_args = grep { defined } ( ( $f_arg // $id // '' ) =~ /([^,"]+)|"([^"]+)"/g ); my $elt_type = $node->element_type($element_name); my $cargo_type = $element->cargo_type; if ( defined $note and not defined $action and not defined $subaction ) { $self->_load_note( $element, $note, $inst, $cmdref ); return 'ok'; } if ( defined $action and $action eq ':=' and $cargo_type eq 'leaf' ) { $logger->debug("_load_list: set whole list with ':=' action"); # valid for check_list or list $logger->info( "Setting $elt_type element ", $element->name, " with '$id'" ); $element->load( $id, check => $check ); $self->_load_note( $element, $note, $inst, $cmdref ); return 'ok'; } # compat mode for list=a,b,c,d commands if ( not defined $action and defined $subaction and $subaction eq '=' and $cargo_type eq 'leaf' ) { $logger->debug("_load_list: set whole list with '=' subaction'"); # valid for check_list or list $logger->info( "Setting $elt_type element ", $element->name, " with '$value'" ); $element->load( $value, check => $check ); $self->_load_note( $element, $note, $inst, $cmdref ); return 'ok'; } unquote( $id, $value, $note ); if ( defined $action ) { my $dispatch = $dispatch_action{ 'list_' . $cargo_type }{$action} || $dispatch_action{ 'list_*'}{$action} || $dispatch_action{$cargo_type}{$action} || $dispatch_action{'fallback'}{$action}; if ($dispatch) { 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 ); if ( $cargo_type =~ /node/ ) { # remove possible leading or trailing quote $logger->debug("_load_list: calling _load on node id $id"); return $self->_load( $obj, $check, $cmdref ); } return 'ok' unless defined $subaction; if ( $cargo_type =~ /leaf/ ) { $logger->debug("_load_list: calling _load_value on $cargo_type id $id"); $self->_load_value( $obj, $check, $subaction, $value ) and return 'ok'; } } my $a_str = defined $action ? $action : ''; Config::Model::Exception::Load->throw( object => $element, command => join( '', map { $_ || '' } @$inst ), error => "Wrong assignment with '$a_str' on " . "element type: $elt_type, cargo_type: $cargo_type" ); } sub _load_hash { my ( $self, $node, $check, $inst, $cmdref ) = @_; my ( $element_name, $action, $f_arg, $id, $subaction, $value, $note ) = @$inst; unquote( $id, $value, $note ); my $element = $node->fetch_element( name => $element_name, check => $check ); my $cargo_type = $element->cargo_type; if ( defined $note and not defined $action ) { $self->_load_note( $element, $note, $inst, $cmdref ); return 'ok'; } if ( not defined $action ) { Config::Model::Exception::Load->throw( object => $element, command => join( '', map { $_ || '' } @$inst ), error => "Missing key (e.g. '$element_name:some_key') on hash element, cargo_type: $cargo_type" ); } if ( $action eq ':~' ) { my @keys = $element->fetch_all_indexes; my $ret = 'ok'; $id =~ s!^/|/$!!g if $id; my @loop_on = $id ? grep { /$id/ } @keys : @keys; if ($logger->is_debug) { my $str = $id ? " with regex /$id/" : ''; $logger->debug("_load_hash: looping$str on keys @loop_on"); } my @saved_cmd = @$cmdref; foreach my $loop_id ( @loop_on ) { @$cmdref = @saved_cmd; # restore command before loop $logger->debug("_load_hash: loop on id $loop_id"); my $sub_elt = $element->fetch_with_id($loop_id); if ( $cargo_type =~ /node/ ) { # remove possible leading or trailing quote $ret = $self->_load( $sub_elt, $check, $cmdref ); } elsif ( $cargo_type =~ /leaf/ ) { $ret = $self->_load_value( $sub_elt, $check, $subaction, $value ); } else { Config::Model::Exception::Load->throw( object => $element, command => join( '', @$inst ), error => "Hash assignment with '$action' on unexpected " . "cargo_type: $cargo_type" ); } $logger->debug("_load_hash: loop on id $loop_id returned $ret (left cmd: @$cmdref)"); if ( $ret eq 'error') { return $ret; } } return $ret; } my @f_args = grep { defined } ( ( $f_arg // $id // '' ) =~ /([^,"]+)|"([^"]+)"/g ); if ( defined $action ) { my $dispatch = $dispatch_action{ 'hash_' . $cargo_type }{$action} || $dispatch_action{ 'hash_*'}{$action} || $dispatch_action{$cargo_type}{$action} || $dispatch_action{'fallback'}{$action}; if ($dispatch) { # todo missing arguments 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 ); if ( $action eq ':' and $cargo_type =~ /node/ ) { # remove possible leading or trailing quote $logger->debug("_load_hash: calling _load on node $id"); if ( defined $subaction ) { Config::Model::Exception::Load->throw( object => $element, command => join( '', @$inst ), error => qq!Hash assignment with '$action"$id"$subaction"$value"' on unexpected ! . "cargo_type: $cargo_type" ); } return $self->_load( $obj, $check, $cmdref ); } elsif ( $action eq ':' and defined $subaction and $cargo_type =~ /leaf/ ) { $logger->debug("_load_hash: calling _load_value on leaf $id"); $self->_load_value( $obj, $check, $subaction, $value ) and return 'ok'; } elsif ( $action eq ':' and defined $note ) { # action was just to store annotation return 'ok'; } elsif ($action) { Config::Model::Exception::Load->throw( object => $element, command => join( '', grep { defined $_ } @$inst ), error => "Hash assignment with '$action' on unexpected " . "cargo_type: $cargo_type" ); } } sub _load_leaf { my ( $self, $node, $check, $inst, $cmdref ) = @_; my ( $element_name, $action, $f_arg, $id, $subaction, $value, $note ) = @$inst; unquote( $id, $value ); my $element = $node->fetch_element( name => $element_name, check => $check ); $self->_load_note( $element, $note, $inst, $cmdref ); if ( defined $action and $element->isa('Config::Model::Value')) { if ($action eq '~') { $logger->debug("_load_leaf: action '$action' deleting value"); $element->store(value => undef, check => $check); } elsif ($action eq ':') { Config::Model::Exception::Load->throw( object => $element, command => $inst, error => "Error: list or hash command (':') detected on a leaf." . "(element '" . $element->name . "')" ); } else { Config::Model::Exception::Load->throw( object => $element, command => $inst, error => "Load error on leaf with " . "'$element_name$action$id' command " . "(element '" . $element->name . "')" ); } } return 'ok' unless defined $subaction; if ( $logger->is_debug ) { my $msg = defined $value ? $value : ''; $msg =~ s/\n/\\n/g; $logger->debug("_load_leaf: action '$subaction' value '$msg'"); } my $res = $self->_load_value( $element, $check, $subaction, $value, $inst ); return $res if $res ; Config::Model::Exception::Load->throw( object => $element, command => $inst, error => "Load error on leaf with " . "'$element_name$subaction$value' command " . "(element '" . $element->name . "')" ); } sub _load_value { my ( $self, $element, $check, $subaction, $value, $inst ) = @_; $logger->debug("_load_value: action '$subaction' value '$value' check $check"); if ( $subaction eq '=' and $element->isa('Config::Model::Value') ) { $element->store( value => $value, check => $check ); } elsif ( $subaction eq '.=' and $element->isa('Config::Model::Value') ) { my $orig = $element->fetch( check => $check ); $element->store( value => $orig . $value, check => $check ); } elsif ( $subaction eq '=~' and $element->isa('Config::Model::Value') ) { my $orig = $element->fetch( check => $check ); if ( defined $orig ) { eval("\$orig =~ $value;"); if ($@) { Config::Model::Exception::Load->throw( object => $element, command => $inst, error => "Failed regexp '$value' on " . "element '" . $element->name . "' : $@" ); } $element->store( value => $orig, check => $check ); } } else { return undef; } $logger->debug("_load_value: done returns ok"); return 'ok'; } 1; # ABSTRACT: Load serialized data into config tree __END__ =pod =encoding UTF-8 =head1 NAME Config::Model::Loader - Load serialized data into config tree =head1 VERSION version 2.097 =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 ( ) No parameter. The constructor should be used only by L. =head1 load string syntax The string is made of the following items (also called C) separated by spaces. These actions can be divided in 4 groups: =over =item * navigation: moving up and down the configuration tree. =item * list and hash operation: select, add or delete hash or list item (also known as C items) =item * leaf operation: select, modify or delecte leaf value =item * annotation: modify or delete configuration annotation (aka comment) =back =head2 navigation =over 8 =item - Go up one node =item ! Go to the root node of the configuration tree. =item xxx Go down using C element. (For C type element) =item /xxx Go up until the element C is found. This search can be combined with one of the command specified below, e.g C =back =head2 list and hash operation =over =item xxx:yy Go down using C element and id C (For C or C element with C cargo_type). Literal C<\n> are replaced by real C<\n> (LF in Unix). =item xxx:~yy Go down using C element and loop over the ids that match the regex specified by C. (For C). For instance, with C model, you could do Host:~"/.*.debian.org/" user='foo-guest' to set "foo-user" users for all your debian accounts. The leading and trailing '/' may be omitted. Be sure to surround the regexp with double quote if space are embedded in the regex. Note that the loop ends when the load command goes above the element where the loop is executed. For instance, the instruction below 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:-yy Delete item referenced by C element and id C. For a list, this is equivalent to C. This command does not go down in the tree (since it has just deleted the element). I.e. a 'C<->' is generally not needed afterwards. =item xxx:-=yy Remove the element whose value is C. For list or hash of leaves. Does not not complain if the value to delete is not found. =item xxx:-~/yy/ Remove the element whose value matches C. For list or hash of leaves. Does not not complain if no value were deleted. =item xxx:=~s/yy/zz/ Substitute a value with another. Perl switches can be used(e.g. C) =item xxx: value on C list =item xxx:>yy or xxx:.unshift(yy) Unshift C value on C list =item xxx:@ or xxx:.sort Sort the list =item xxx:.insert_at(yy,zz) Insert C value on C list before B C. =item xxx:.insert_before(yy,zz) Insert C value on C list before B C. =item xxx:.insert_before(/yy/,zz) Insert C value on C list before B matching C. =item xxx:.insort(zz) Insert C value on C list so that existing alphanumeric order is preserved. =item xxx:.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:.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). =back =head2 annotation =over =item xxx#zzz or xxx:yyy#zzz Element annotation. Can be quoted or not quoted. Note that annotations are always placed at the end of an action item. I.e. C, C or C are valid. C is B valid. =back =head2 Quotes You can surround indexes and values with double quotes. E.g.: a_string="\"foo\" and \"bar\"" =head1 Examples You can use L to modify configuration with C command. For instance, if L is installed, you can run: cme modify ssh 'ControlMaster=auto ControlPath="~/.ssh/master-%r@%n:%p"' To delete C entry: cme modify ssh 'Host:-"*"' To specify 2 C with a single command: cme modify ssh 'Host:"foo* bar*" ForwardX11=yes HostName="foo.com" - Host:baz HostName="baz.com"' Note the 'C<->' used to go up one node before "C". In this case, "up one node" leads to the "root node", so "C" could also be used instead of "C<->": cme modify ssh 'Host:"foo* bar*" ForwardX11=yes HostName="foo.com" ! Host:baz HostName="baz.com"' Let's modify now the host name of using a C<.org> domain instead of C<.com>. The C<:~> operator uses a regexp to loop over several Host entries: cme modify ssh 'Host:~/ba[rz]/ HostName=~s/.com$/.org/' Now that ssh config is mucked up with dummy entries, let's clean up: cme modify ssh 'Host:-"baz" Host:-"foo* bar*"' =head1 Methods =head2 load ( ... ) Load data into the node tree (from the node passed with C) and fill values as we go following the instructions passed with C. (C can also be an array ref). Parameters are: =over =item node node ref of the root of the tree (of sub-root) to start the load from. =item 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. =back =head1 AUTHOR Dominique Dumont, (ddumont at cpan dot org) =head1 SEE ALSO L,L,L =head1 AUTHOR Dominique Dumont =head1 COPYRIGHT AND LICENSE This software is Copyright (c) 2005-2016 by Dominique Dumont. This is free software, licensed under: The GNU Lesser General Public License, Version 2.1, February 1999 =cut Config-Model-2.097/lib/Config/Model/Iterator.pm0000644000175000017500000003164713027007223017611 0ustar domidomi# # This file is part of Config-Model # # This software is Copyright (c) 2005-2016 by Dominique Dumont. # # This is free software, licensed under: # # The GNU Lesser General Public License, Version 2.1, February 1999 # package Config::Model::Iterator; $Config::Model::Iterator::VERSION = '2.097'; use Carp; use strict; use warnings; use Config::Model::ObjTreeScanner; use Log::Log4perl qw(get_logger :levels); use Config::Model::Exception; my $logger = get_logger("Iterator"); sub new { my $type = shift; my %args = @_; my $self = { call_back_on_important => 0, forward => 1, status => 'standard', }; if (delete $args{experience}) { carp "experience parameter is deprecated"; } foreach my $p (qw/root/) { $self->{$p} = delete $args{$p} or croak "Iterator->new: Missing $p parameter"; } foreach my $p (qw/call_back_on_important call_back_on_warning status/) { $self->{$p} = delete $args{$p} if defined $args{$p}; } bless $self, $type; my %cb_hash; # mandatory call-back parameters foreach my $item (qw/leaf_cb hash_element_cb/) { $cb_hash{$item} = delete $args{$item} or croak "Iterator->new: Missing $item parameter"; } # handle optional list_element_cb parameter $cb_hash{list_element_cb} = delete $args{list_element_cb} || $cb_hash{hash_element_cb}; # optional call-back parameter $cb_hash{check_list_element_cb} = delete $args{check_list_element_cb} || $cb_hash{leaf_cb}; # optional call-back parameters foreach my $p ( qw/enum_value reference_value integer_value number_value boolean_value string_value uniline_value/ ) { my $item = $p . '_cb'; $cb_hash{$item} = delete $args{$item} || $cb_hash{leaf_cb}; } $self->{dispatch_cb} = \%cb_hash; if (%args) { die "Iterator->new: unexpected parameters: ", join( ' ', keys %args ), "\n"; } # user call-back are *not* passed to ObjTreeScanner. They will be # called indirectly through wizard-helper own call-backs $self->{scanner} = Config::Model::ObjTreeScanner->new( fallback => 'all', hash_element_cb => sub { $self->hash_element_cb(@_) }, list_element_cb => sub { $self->hash_element_cb(@_) }, node_content_cb => sub { $self->node_content_cb(@_) }, leaf_cb => sub { $self->leaf_cb(@_) }, ); return $self; } sub start { my $self = shift; $self->{bail_out} = 0; $self->{scanner}->scan_node( undef, $self->{root} ); } sub bail_out { my $self = shift; $self->{bail_out} = 1; } # internal. This call-back is passed to ObjTreeScanner. It will call # scan_element in an order which depends on $self->{forward}. sub node_content_cb { my ( $self, $scanner, $data_r, $node, @element ) = @_; $logger->info( "node_content_cb called on '", $node->name, "' element: @element" ); my $element; while (1) { # @element from ObjTreeScanner is not used as user actions may # change the element list due to warping $element = $node->next_element( name => $element, status => $self->{status}, reverse => 1 - $self->{forward} ); last unless defined $element; $logger->info( "node_content_cb calls scan_element ", "on element $element" ); $self->{scanner}->scan_element( $data_r, $node, $element ); return if $self->{bail_out}; } } # internal. Used to find which user call-back to use for a given # element type. sub get_cb { my $self = shift; my $elt_type = shift; return $self->{dispatch_cb}{ $elt_type . '_cb' } || croak "wizard get_cb: unexpected type $elt_type"; } # internal. This call-back is passed to ObjTreeScanner. It will call # scan_hash in an order which depends on $self->{forward}. it will # also check if the hash (or list) element is flagged as 'important' # and call user's hash or list call-back if needed sub hash_element_cb { my ( $self, $scanner, $data_r, $node, $element ) = splice @_, 0, 5; my @keys = sort @_; my $level = $node->get_element_property( element => $element, property => 'level' ); $logger->info( "hash_element_cb (element $element) called on '", $node->location, "' level $level, keys: '@keys'" ); # get the call-back to use my $cb = $self->get_cb( $node->element_type($element) . '_element' ); # use the same algorithm for check_important and # scan_element pseudo elements my $i = $self->{forward} == 1 ? 0 : 1; while ( $i >= 0 and $i < 2 ) { if ( $self->{call_back_on_important} and $i == 0 and $level eq 'important' ) { $cb->( $self, $data_r, $node, $element, @keys ); return if $self->{bail_out}; # may be modified in callback # recompute keys as they may have been modified during call-back @keys = $self->{scanner}->get_keys( $node, $element ); } if ( $self->{call_back_on_warning} and $i == 0 and $node->fetch_element($element)->has_warning ) { $logger->info("hash_element_cb found elt with warning: '", $node->name, "' element $element"); $cb->( $self, $data_r, $node, $element, @keys ); } if ( $i == 1 ) { my $j = $self->{forward} == 1 ? 0 : $#keys; while ( $j >= 0 and $j < @keys ) { my $k = $keys[$j]; $logger->info( "hash_element_cb (element $element) calls ", "scan_hash on key $k" ); $self->{scanner}->scan_hash( $data_r, $node, $element, $k ); $j += $self->{forward}; } } $i += $self->{forward}; } } # internal. This call-back is passed to ObjTreeScanner. It will also # check if the leaf element is flagged as 'important' or if the leaf # element contains an error (mostly undefined mandatory values) and # call user's call-back if needed sub leaf_cb { my ( $self, $scanner, $data_r, $node, $element, $index, $value_obj ) = @_; $logger->info( "leaf_cb called on '", $node->name, "' element '$element'", defined $index ? ", index $index" : '' ); my $elt_type = $node->element_type($element); my $key = $elt_type eq 'check_list' ? 'check_list_element' : $value_obj->value_type . '_value'; my $user_leaf_cb = $self->get_cb($key); my $level = $node->get_element_property( element => $element, property => 'level' ); if ( $self->{call_back_on_important} and $level eq 'important' ) { $logger->info( "leaf_cb found important elt: '", $node->name, "' element $element", defined $index ? ", index $index" : '' ); $user_leaf_cb->( $self, $data_r, $node, $element, $index, $value_obj ); } if ( $self->{call_back_on_warning} and $value_obj->warning_msg ) { $logger->info( "leaf_cb found elt with warning: '", $node->name, "' element $element", defined $index ? ", index $index" : '' ); $user_leaf_cb->( $self, $data_r, $node, $element, $index, $value_obj ); } # now need to check for errors... my $result; eval { $result = $value_obj->fetch(); }; my $e = $@; if ( ref $e and $e->isa('Config::Model::Exception::User') ) { # ignore errors that has just been catched and call user call-back $logger->info( "leaf_cb oopsed on '", $node->name, "' element $element", defined $index ? ", index $index" : '' ); $user_leaf_cb->( $self, $data_r, $node, $element, $index, $value_obj, $e->error ); } elsif ( ref $e ) { $e->rethrow; # does not return ... } elsif ($e) { die "Iterator failed on value object: $e"; } } sub go_forward { my $self = shift; $logger->info("Going forward") if $self->{forward} == -1; $self->{forward} = 1; } sub go_backward { my $self = shift; $logger->info("Going backward") if $self->{forward} == 1; $self->{forward} = -1; } 1; # ABSTRACT: Iterates forward or backward a configuration tree __END__ =pod =encoding UTF-8 =head1 NAME Config::Model::Iterator - Iterates forward or backward a configuration tree =head1 VERSION version 2.097 =head1 SYNOPSIS use Config::Model; # define configuration tree object my $model = Config::Model->new; $model->create_config_class( name => "Foo", element => [ [qw/bar baz/] => { type => 'leaf', value_type => 'string', level => 'important' , }, ] ); $model->create_config_class( name => "MyClass", element => [ foo_nodes => { type => 'hash', # hash id index_type => 'string', level => 'important' , cargo => { type => 'node', config_class_name => 'Foo' }, }, ], ); my $inst = $model->instance( root_class_name => 'MyClass' ); # create some Foo objects $inst->config_root->load("foo_nodes:foo1 - foo_nodes:foo2 ") ; my $my_leaf_cb = sub { my ($iter, $data_r,$node,$element,$index, $leaf_object) = @_ ; print "leaf_cb called for ",$leaf_object->location,"\n" ; } ; my $my_hash_cb = sub { my ($iter, $data_r,$node,$element,@keys) = @_ ; print "hash_element_cb called for element $element with keys @keys\n" ; } ; my $iterator = $inst -> iterator ( leaf_cb => $my_leaf_cb, hash_element_cb => $my_hash_cb , ); $iterator->start ; ### prints # hash_element_cb called for element foo_nodes with keys foo1 foo2 # leaf_cb called for foo_nodes:foo1 bar # leaf_cb called for foo_nodes:foo1 baz # leaf_cb called for foo_nodes:foo2 bar # leaf_cb called for foo_nodes:foo2 baz =head1 DESCRIPTION This module provides a class that is able to iterate forward or backward a configuration tree. The iterator stops and calls back user defined subroutines on one of the following condition: =over =item * A configuration item contains an error (mostly undefined mandatory values) =item * A configuration item contains warnings and the constructor's argument C was set. =item * A configuration item has a C level and the constructor's argument C was set.. See L for details. =back The iterator supports going forward and backward (to support C and C buttons on a wizard widget). =head1 CONSTRUCTOR The constructor should be used only by L with the L method. =head1 Creating an iterator A iterator requires at least two kind of call-back: a call-back for leaf elements and a call-back for hash elements (which is also used for list elements). These call-back must be passed when creating the iterator (the parameters are named C and C) Here are the the parameters accepted by C: =head2 call_back_on_important Whether to call back when an important element is found (default 0). =head2 call_back_on_warning Whether to call back when an item with warnings is found (default 0). =head2 status Specifies the status of the element scanned by the wizard (default 'standard'). =head2 leaf_cb Subroutine called backed for leaf elements. See L for signature and details. (mandatory) =head2 hash_element_cb Subroutine called backed for hash elements. See L for signature and details. (mandatory) =head1 Custom callbacks By default, C is called for all types of leaf elements (i.e enum. integer, strings, ...). But you can provide dedicated call-back for each type of leaf: enum_value_cb, integer_value_cb, number_value_cb, boolean_value_cb, uniline_value_cb, string_value_cb Likewise, you can also provide a call-back dedicated to list elements with C =head1 Methods =head2 start Start the scan and perform call-back when needed. This function returns when the scan is completely done. =head2 bail_out When called, a variable is set so that all call_backs returns as soon as possible. Used to abort wizard. =head2 go_forward Set wizard in forward (default) mode. =head2 go_backward Set wizard in backward mode. =head1 AUTHOR Dominique Dumont, (ddumont at cpan dot org) =head1 SEE ALSO L, L, L, L, L, L, L, L, =head1 AUTHOR Dominique Dumont =head1 COPYRIGHT AND LICENSE This software is Copyright (c) 2005-2016 by Dominique Dumont. This is free software, licensed under: The GNU Lesser General Public License, Version 2.1, February 1999 =cut Config-Model-2.097/lib/Config/Model/Backend/0000755000175000017500000000000013027007223016776 5ustar domidomiConfig-Model-2.097/lib/Config/Model/Backend/IniFile.pm0000644000175000017500000005034513027007223020662 0ustar domidomi# # This file is part of Config-Model # # This software is Copyright (c) 2005-2016 by Dominique Dumont. # # This is free software, licensed under: # # The GNU Lesser General Public License, Version 2.1, February 1999 # package Config::Model::Backend::IniFile; $Config::Model::Backend::IniFile::VERSION = '2.097'; use Carp; use Mouse; use 5.10.0; use Config::Model::Exception; use File::Path; use Log::Log4perl qw(get_logger :levels); use base qw/Config::Model::Backend::Any/; my $logger = get_logger("Backend::IniFile"); sub suffix { return '.ini'; } sub annotation { return 1; } sub read { my $self = shift; my %args = @_; # args is: # object => $obj, # Config::Model::Node object # root => './my_test', # fake root directory, userd for tests # config_dir => /etc/foo', # absolute path # file => 'foo.conf', # file name # file_path => './my_test/etc/foo/foo.conf' # io_handle => $io # IO::File object # check => yes|no|skip return 0 unless defined $args{io_handle}; # no file to read my $section = ''; # dumb value used for logging my $delimiter = $args{comment_delimiter} || '#'; my $hash_class = $args{store_class_in_hash} || ''; my $section_map = $args{section_map} || {}; my $split_reg = $args{split_list_value}; my $check = $args{check} || 'yes'; my $obj = $self->node; my %force_lc; map { $force_lc{$_} = $args{"force_lc_$_"} ? 1 : 0; } qw/section key value/; #FIXME: Is it possible to store the comments with their location #in the file? It would be nice if comments that are after values #in input file, would be written in the same way in the output #file. Also, comments at the end of file are being ignored now. my @lines = $args{io_handle}->getlines; # try to get global comments (comments before a blank line) $self->read_global_comments( \@lines, $delimiter ); my @assoc = $self->associates_comments_with_data( \@lines, $delimiter ); # store INI data in a structure: # { # name => value leaf # name => [ value ] list # name => { key => value , ... } hash # name => { ... } node # name => [ { ... }, ... ] list of nodes # name => { key => { ... } , ... } hash of nodes # } my $ini_data = {}; my %ini_comment; my $section_ref = $ini_data; my $section_path = ''; foreach my $item (@assoc) { my ( $vdata, $comment ) = @$item; $logger->debug("ini read: reading '$vdata'"); my $comment_path; # Update section name if ( $vdata =~ /^\s*\[(.*)\]/ ) { $section = $force_lc{section} ? lc($1) : $1; my $remap = $section_map->{$section} || ''; if ( $remap eq '!' ) { $section_ref = $ini_data; $comment_path = $section_path = ''; $logger->debug("step 1: found node [$section]"); } elsif ($remap) { $section_ref = {}; $logger->debug("step 1: found node $remap [$section]"); $section_path = $comment_path = $self->set_or_push( $ini_data, $remap, $section_ref ); } elsif ($hash_class) { $ini_data->{$hash_class}{$section} = $section_ref = {}; $comment_path = $section_path = "$hash_class:$section"; $logger->debug("step 1: found node $hash_class and path $comment_path [$section]"); } else { $section_ref = {}; $logger->debug("step 1: found node $section [$section]"); $section_path = $comment_path = $self->set_or_push( $ini_data, $section, $section_ref ); } # for write later, need to store the obj if section map was used if ( defined $section_map->{$section} ) { $logger->debug("store section_map loc '$section_path' section '$section'"); $self->{reverse_section_map}{$section_path} = $section; } } else { my ( $name, $val ) = split( /\s*=\s*/, $vdata, 2 ); $name = lc($name) if $force_lc{key}; $val = lc($val) if $force_lc{value}; $comment_path = $section_path . ' ' . $self->set_or_push( $section_ref, $name, $val ); $logger->debug("step 1: found node $comment_path name $name in [$section]"); } $ini_comment{$comment_path} = $comment if $comment; } my @load_args = ( data => $ini_data, check => $check ); push @load_args, split_reg => qr/$split_reg/ if $split_reg; $self->load_data(@load_args); while ( my ( $k, $v ) = each %ini_comment ) { my $item = $obj->grab( step => $k, mode => 'loose' ) or next; $item = $item->fetch_with_id(0) if $item->get_type eq 'list'; $item->annotation($v); } return 1; } sub load_data { my $self = shift; $self->node->load_data(@_); } sub set_or_push { my ( $self, $ref, $name, $val ) = @_; my $cell = $ref->{$name}; my $path; if ( defined $cell and ref($cell) eq 'ARRAY' ) { push @$cell, $val; $path = $name . ':' . $#$cell; } elsif ( defined $cell ) { $ref->{$name} = [ $cell, $val ]; $path = $name . ':1'; } else { $ref->{$name} = $val; $path = $name; # no way to distinguish between leaf and first value of list } return $path; } sub write { my $self = shift; my %args = @_; # args is: # object => $obj, # Config::Model::Node object # root => './my_test', # fake root directory, userd for tests # config_dir => /etc/foo', # absolute path # file => 'foo.conf', # file name # file_path => './my_test/etc/foo/foo.conf' # io_handle => $io # IO::File object # check => yes|no|skip my $ioh = $args{io_handle}; my $node = $args{object}; my $delimiter = $args{comment_delimiter} || '#'; croak "Undefined file handle to write" unless defined $ioh; # use the first char of the list as a comment delimeter my $cc = substr($delimiter,0,1); $args{comment_delimiter} = $cc; $self->write_global_comment( $ioh, $cc ); # some INI file have a 'General' section mapped in root node my $top_class_name = $self->{reverse_section_map}{''}; if ( defined $top_class_name ) { $logger->debug("writing class $top_class_name from reverse_section_map"); $self->write_data_and_comments( $ioh, $cc, "[$top_class_name]" ); } my $res = $self->_write(%args); $ioh->print($res); } sub _write_list{ my ($self, $args, $node, $elt) = @_ ; my $res = ''; my $join_list = $args->{join_list_value}; my $delimiter = $args->{comment_delimiter} || '#'; my $obj = $node->fetch_element($elt); my $obj_note = $obj->annotation; if ( $join_list ) { my @v = grep { length } $obj->fetch_all_values(); my $v = join( $join_list, @v ); if ( length($v) ) { $logger->debug("writing joined list elt $elt -> $v"); $res .= $self->write_data_and_comments( undef, $delimiter, "$elt=$v", $obj_note ); } } else { foreach my $item ( $obj->fetch_all('custom') ) { my $note = $item->annotation; my $v = $item->fetch; if ( length $v ) { $logger->debug("writing list elt $elt -> $v"); $res .= $self->write_data_and_comments( undef, $delimiter, "$elt=$v", $obj_note . $note ); } else { $logger->debug("NOT writing undef or empty list elt"); } } } return $res; } sub _write_check_list{ my ($self, $args, $node, $elt) = @_ ; my $res = ''; my $join_check_list = $args->{join_check_list_value}; my $delimiter = $args->{comment_delimiter} || '#'; my $obj = $node->fetch_element($elt); my $obj_note = $obj->annotation; if ($join_check_list ) { my $v = join( $join_check_list, $obj->get_checked_list() ); if ( length($v) ) { $logger->debug("writing check_list elt $elt -> $v"); $res .= $self->write_data_and_comments( undef, $delimiter, "$elt=$v", $obj_note ); } } else { foreach my $v ( $obj->get_checked_list() ) { $logger->debug("writing joined check_list elt $elt -> $v"); $res .= $self->write_data_and_comments( undef, $delimiter, "$elt=$v", $obj_note ); } } return $res; } sub _write_leaf{ my ($self, $args, $node, $elt) = @_ ; my $res = ''; my $write_bool_as = $args->{write_boolean_as}; my $delimiter = $args->{comment_delimiter} || '#'; my $obj = $node->fetch_element($elt); my $obj_note = $obj->annotation; my $v = $obj->fetch; if ( $write_bool_as and defined($v) and length($v) and $obj->value_type eq 'boolean' ) { $v = $write_bool_as->[$v]; } if ( defined $v and length $v ) { $logger->debug("writing leaf elt $elt -> $v"); $res .= $self->write_data_and_comments( undef, $delimiter, "$elt=$v", $obj_note ); } else { $logger->debug("NOT writing undef or empty leaf elt"); } return $res; } sub _write_hash { my ($self, $args, $node, $elt) = @_ ; my $res = ''; my $delimiter = $args->{comment_delimiter} || '#'; my $obj = $node->fetch_element($elt); my $obj_note = $obj->annotation; foreach my $key ( $obj->fetch_all_indexes ) { my $hash_obj = $obj->fetch_with_id($key); my $note = $hash_obj->annotation; $logger->debug("writing hash elt $elt key $key"); my $subres = $self->_write( %$args, object => $hash_obj ); if ($subres) { $res .= "\n" . $self->write_data_and_comments( undef, $delimiter, "[$key]", $obj_note . $note ) . $subres; } } return $res; } sub _write_node { my ($self, $args, $node, $elt) = @_ ; my $res = ''; my $delimiter = $args->{comment_delimiter} || '#'; my $obj = $node->fetch_element($elt); my $obj_note = $obj->annotation; $logger->debug("writing class $elt"); my $subres = $self->_write( %$args, object => $obj ); if ($subres) { # some INI file may have a section mapped to a node as exception to mapped in a hash my $exception_name = $self->{reverse_section_map}{ $obj->location }; if ( defined $exception_name ) { $logger->debug("writing class $exception_name from reverse_section_map"); } my $c_name = $exception_name || $elt; $res .= "\n" . $self->write_data_and_comments( undef, $delimiter, "[$c_name]", $obj_note ) . $subres; } return $res; } sub _write { my $self = shift; my %args = @_; my $node = $args{object}; my $delimiter = $args{comment_delimiter} || '#'; $logger->debug( "called on ", $node->name ); my $res = ''; # Using Config::Model::ObjTreeScanner would be overkill # first write list and element, then classes foreach my $elt ( $node->get_element_name ) { my $type = $node->element_type($elt); $logger->debug("first loop on elt $elt type $type"); next if $type =~ /node/ or $type eq 'hash'; if ( $type eq 'list' ) { $res .= $self->_write_list (\%args, $node, $elt) ; } elsif ( $type eq 'check_list') { $res .= $self->_write_check_list (\%args, $node, $elt) ; } elsif ( $type eq 'leaf' ) { $res .= $self->_write_leaf (\%args, $node, $elt) ; } else { Config::Model::Exception::Model->throw( error => "unexpected type $type for leaf elt $elt", object => $node ); } } foreach my $elt ( $node->get_element_name ) { my $type = $node->element_type($elt); $logger->debug("second loop on elt $elt type $type"); next unless $type =~ /node/ or $type eq 'hash'; my $obj = $node->fetch_element($elt); my $obj_note = $obj->annotation; if ( $type eq 'hash' ) { $res .= $self->_write_hash (\%args, $node, $elt) ; } else { $res .= $self->_write_node (\%args, $node, $elt) ; } } $logger->debug( "done on ", $node->name ); return $res; } no Mouse; __PACKAGE__->meta->make_immutable; 1; # ABSTRACT: Read and write config as a INI file __END__ =pod =encoding UTF-8 =head1 NAME Config::Model::Backend::IniFile - Read and write config as a INI file =head1 VERSION version 2.097 =head1 SYNOPSIS use Config::Model; my $model = Config::Model->new; $model->create_config_class ( name => "IniClass", element => [ [qw/foo bar/] => { type => 'list', cargo => {qw/type leaf value_type string/} } ] ); # model for free INI class name and constrained class parameters $model->create_config_class( name => "MyClass", element => [ ini_class => { type => 'hash', index_type => 'string', cargo => { type => 'node', config_class_name => 'IniClass' }, }, ], read_config => [ { backend => 'IniFile', config_dir => '/tmp', file => 'foo.conf', store_class_in_hash => 'ini_class', auto_create => 1, } ], ); my $inst = $model->instance(root_class_name => 'MyClass' ); my $root = $inst->config_root ; $root->load('ini_class:ONE foo=FOO1 bar=BAR1 - ini_class:TWO foo=FOO2' ); $inst->write_back ; Now C 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 ( node => $node_obj, name => 'inifile' ) ; Inherited from L. The constructor is called by L. =head1 Parameters Optional parameters declared in the model: =over =item comment_delimiter Change the character that starts comments in the INI file. Default is 'C<#>'. 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>. =item store_class_in_hash See L =item section_map Is a kind of exception of the above rule. See also L =item force_lc_section Boolean. When set, sections names are converted to lowercase. =item force_lc_key Idem for key name =item force_lc_value Idem for all values. =item split_list_value Some INI values are in fact a list of items separated by a space or a comma. This parameter specifies the regex to use to split the value into a list. This applies only to C elements. =item join_list_value Conversely, the list element split with C needs to be written back with a string to join them. Specify this string (usually ' ' or ', ') with C. =item split_check_list_value Some INI values are in fact a check list of items separated by a space or a comma. This parameter specifies the regex to use to split the value read from the file into a list of items to check. This applies only to C elements. =item join_check_list_value Conversely, the check_list element split with C needs to be written back with a string to join them. Specify this string (usually ' ' or ', ') with C. =item write_boolean_as Array ref. Reserved for boolean value. Specify how to write a boolean value. Default is C<[0,1]> which may not be the most readable. C can be specified as C<['false','true']> or C<['no','yes']>. =back =head1 Mapping between INI structure and model INI file typically have the same structure with 2 different conventions. The class names can be imposed by the application or may be chosen by user. =head2 Imposed class name In this case, the class names must match what is expected by the application. The elements of each class can be different. For instance: foo = foo_v [ A ] bar = bar_v [ B ] baz = baz_v In this case, class C and class C 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: read_config => [ { backend => 'IniFile', config_dir => '/tmp', file => 'foo.ini', store_class_in_hash => 'my_class_holder', } ], Of course they are exceptions. For instance, in C, the C<[General]> INI class must be mapped to a specific node object. This can be specified with the C parameter: read_config => [ { backend => 'IniFile', config_dir => '/tmp', file => 'foo.ini', store_class_in_hash => 'my_class_holder', section_map => { General => 'general_node', } } ], C can also map an INI class to the root node: read_config => [ { backend => 'ini_file', store_class_in_hash => 'sections', section_map => { General => '!' }, } ], =head1 Methods =head2 read ( io_handle => ... ) Of all parameters passed to this read call-back, only C is used. This parameter must be L object already opened for read. It can also be undef. In this case, C returns 0. When a file is read, C returns 1. =head2 write ( io_handle => ... ) Of all parameters passed to this write call-back, only C is used. This parameter must be L object already opened for write. C 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-2016 by Dominique Dumont. This is free software, licensed under: The GNU Lesser General Public License, Version 2.1, February 1999 =cut Config-Model-2.097/lib/Config/Model/Backend/Any.pm0000644000175000017500000003372013027007223020070 0ustar domidomi# # This file is part of Config-Model # # This software is Copyright (c) 2005-2016 by Dominique Dumont. # # This is free software, licensed under: # # The GNU Lesser General Public License, Version 2.1, February 1999 # package Config::Model::Backend::Any; $Config::Model::Backend::Any::VERSION = '2.097'; use Carp; use strict; use warnings; use Config::Model::Exception; use Mouse; use File::Path; use Log::Log4perl qw(get_logger :levels); my $logger = get_logger("Backend"); has 'name' => ( is => 'ro', default => 'unknown', ); has 'annotation' => ( is => 'ro', isa => 'Bool', default => 0 ); has 'node' => ( is => 'ro', isa => 'Config::Model::Node', weak_ref => 1, required => 1, handles => ['show_message', 'instance'], ); sub suffix { my $self = shift; $logger->info( "Internal warning: suffix called for backend $self->{name}.This method can be overloaded" ); return undef; } sub read { my $self = shift; my $err = "Internal error: read not defined in backend $self->{name}."; $logger->error($err); croak $err; } sub write { my $self = shift; my $err = "Internal error: write not defined in backend $self->{name}."; $logger->error($err); croak $err; } sub read_global_comments { my $self = shift; my $lines = shift; my $cc = shift; # comment character(s) my $cc_re = length $cc > 1 ? "[$cc]" : $cc; my @global_comments; 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; push @global_comments, $comment if defined $comment; if ( $l =~ /^\s*$/ or $data ) { if (@global_comments) { $self->node->annotation(@global_comments); $logger->debug("Setting global comment with @global_comments"); } # put back any data and comment unshift @$lines, $l unless $l =~ /^\s*$/; # stop global comment at first blank or non comment line last; } } } sub associates_comments_with_data { my $self = shift; my $lines = shift; my $cc = shift; # comment character(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->debug("associates_comments_with_data: '$note' with '$data'"); push @result, [ $data, $note ]; @comments = (); } } return wantarray ? @result : \@result; } sub write_global_comment { my ( $self, $ioh, $cc ) = @_; # no need to mention 'cme list' if current application is found my $app = $self->node->instance->application ; my $extra = '' ; if (not $app) { $extra = "$cc$cc Run 'cme list' to get the list of applications" . " available on your system\n"; $app = ''; } my $res = "$cc$cc This file was written by cme command.\n" . "$cc$cc You can run 'cme edit $app' to modify this file.\n" . $extra . "$cc$cc You may also modify the content of this file with your favorite editor.\n\n"; # write global comment my $global_note = $self->node->annotation; if ($global_note) { map { $res .= "$cc $_\n" } split /\n/, $global_note; $res .= "\n"; } $ioh->print($res) if defined $ioh; return $res; } sub write_data_and_comments { my ( $self, $ioh, $cc, @data_and_comments ) = @_; my $res = ''; while (@data_and_comments) { my ( $d, $c ) = splice @data_and_comments, 0, 2; if ($c) { map { $res .= "$cc $_\n" } split /\n/, $c; } $res .= "$d\n" if defined $d; } $ioh->print($res) if defined $ioh; return $res; } __PACKAGE__->meta->make_immutable; 1; # ABSTRACT: Virtual class for other backends __END__ =pod =encoding UTF-8 =head1 NAME Config::Model::Backend::Any - Virtual class for other backends =head1 VERSION version 2.097 =head1 SYNOPSIS package Config::Model::Backend::Foo ; use Mouse ; extends 'Config::Model::Backend::Any'; # optional sub suffix { return '.conf'; } # 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 => './my_test/etc/foo/foo.conf' # io_handle => $io # IO::File object opened for read # check => yes|no|skip return 0 unless defined $args{io_handle} ; # or die, your choice # read the file line by line # we assume the file contain lines like 'key=value' foreach ($args{io_handle}->getlines) { 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 => './my_test/etc/foo/foo.conf' # io_handle => $io # IO::File object opened for write # check => yes|no|skip my $ioh = $args{io_handle} ; # read the content of the configuration tree foreach my $elt ($self->node->children) { # read the value from element $elt my $v = $self->node->grab_value($elt) ; # write value in file $ioh->print(qq!$elt="$v"\n!) if defined $v ; } 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: read_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: read_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, # full file name (root+path+file) io_handle => $io_file # IO::File object opened for read 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, 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) io_handle => $fh, # IO::File object 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 If C is defined, the backup has already been done before opening the config file. If C is not defined, there's not enough information in the model to read the configuration file and create the backup. Your C method will have to do the backup requested by user. When both C and C are specified, the L opens the configuration file for write (and thus clobbers it) before calling the C call-back with the file handle with C parameter. C should use this handle to write data in the target configuration file. If this behavior causes problem, the solution is either to override C method in your backend that returns C<1>. =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 ( node => $node_obj, name => backend_name ) The constructor should be used only by L. =head1 Methods to override =head2 annotation Whether the backend supports reading and writing annotation (a.k.a comments). Default is 0. Override this method to return 1 if your backend supports annotations. =head2 suffix Suffix of the configuration file. This method returns C by default. =head2 read Read the configuration file. This method must be overridden. =head2 write Write the configuration file. This method must be overridden. =head1 Methods =head2 node Return the node (a L) holding this backend. =head2 instance Return the instance (a L) holding this configuration. =head2 show_message( string ) Show a message to STDOUT (unless overridden). Delegated to L. =head2 read_global_comments 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. 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( io_handle , comment_char) Write global comments from configuration root annotation into the io_handle (if defined). Returns the string written to the io_handle. =head2 write_data_and_comments( io_handle , comment_char , data1, comment1, data2, comment2 ...) Write data and comments in the C (if defined). Comments are written before the data. Returns the string written to the io_handle. If a data is undef, the comment is written on its own line. =head1 AUTHOR Dominique Dumont, (ddumont at cpan dot org) =head1 SEE ALSO L, L, L, L, =head1 AUTHOR Dominique Dumont =head1 COPYRIGHT AND LICENSE This software is Copyright (c) 2005-2016 by Dominique Dumont. This is free software, licensed under: The GNU Lesser General Public License, Version 2.1, February 1999 =cut Config-Model-2.097/lib/Config/Model/Backend/Yaml.pm0000644000175000017500000001364413027007223020246 0ustar domidomi# # This file is part of Config-Model # # This software is Copyright (c) 2005-2016 by Dominique Dumont. # # This is free software, licensed under: # # The GNU Lesser General Public License, Version 2.1, February 1999 # package Config::Model::Backend::Yaml; $Config::Model::Backend::Yaml::VERSION = '2.097'; use Carp; use strict; use warnings; use Config::Model::Exception; use File::Path; use Log::Log4perl qw(get_logger :levels); use base qw/Config::Model::Backend::Any/; use YAML::Any; my $logger = get_logger("Backend::Yaml"); sub suffix { return '.yml'; } sub single_element { my $self = shift; my @elts = $self->node->children; return undef if @elts != 1; my $obj = $self->node->fetch_element($elts[0]); my $type = $obj->get_type; return $type =~ /^(list|hash)$/ ? $obj : undef ; } sub read { my $self = shift; my %args = @_; # args is: # object => $obj, # Config::Model::Node object # root => './my_test', # fake root directory, userd for tests # config_dir => /etc/foo', # absolute path # file => 'foo.conf', # file name # file_path => './my_test/etc/foo/foo.conf' # io_handle => $io # IO::File object # check => yes|no|skip return 0 unless defined $args{io_handle}; # no file to read # load yaml file my $yaml = join( '', $args{io_handle}->getlines ); # convert to perl data my $perl_data = Load $yaml ; if ( not defined $perl_data ) { $logger->warn("No data found in YAML file $args{file_path}"); return 1; } my $target = $self->single_element // $self->node ; # load perl data in tree $target->load_data( data => $perl_data, check => $args{check} || 'yes' ); return 1; } sub write { my $self = shift; my %args = @_; # args is: # object => $obj, # Config::Model::Node object # root => './my_test', # fake root directory, userd for tests # config_dir => /etc/foo', # absolute path # file => 'foo.conf', # file name # file_path => './my_test/etc/foo/foo.conf' # io_handle => $io # IO::File object # check => yes|no|skip croak "Undefined file handle to write" unless defined $args{io_handle}; my $target = $self->single_element // $self->node ; my $perl_data = $target->dump_as_data( full_dump => $args{full_dump} // 0); my $yaml = Dump $perl_data ; $args{io_handle}->print($yaml); return 1; } 1; # ABSTRACT: Read and write config as a YAML data structure __END__ =pod =encoding UTF-8 =head1 NAME Config::Model::Backend::Yaml - Read and write config as a YAML data structure =head1 VERSION version 2.097 =head1 SYNOPSIS use Config::Model ; use Data::Dumper ; # define configuration tree object my $model = Config::Model->new ; $model ->create_config_class ( name => "MyClass", element => [ [qw/foo bar/] => { type => 'leaf', value_type => 'string' }, baz => { type => 'hash', index_type => 'string' , cargo => { type => 'leaf', value_type => 'string', }, }, ], read_config => [ { backend => 'yaml' , config_dir => '/tmp', file => 'foo.yml', auto_create => 1, } ], ) ; my $inst = $model->instance(root_class_name => 'MyClass' ); my $root = $inst->config_root ; my $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 YAML syntax in C configuration tree. Note: =over 4 =item * Undefined values are skipped for list element. I.e. if a list element contains C<('a',undef,'b')>, the data structure contains C<'a','b'>. =item * YAML file is not created (and may be deleted) when no data is to be written. =back =head2 Class with only one hash element If the root node contains a single hash or list element, only the content of this hash is written in a YAML file. For example, if a class contains: element => [ baz => { type => 'hash', index_type => 'string' , cargo => { type => 'leaf', value_type => 'string', }, }, If the configuration is loaded with: $root->load("baz:one=un baz:two=deux") Then the written YAML file does B show C: --- one: un two: deux Likewise, a YAML file for a class with a single list C element would be written with: --- - un - deux =head1 CONSTRUCTOR =head2 new ( node => $node_obj, name => 'yaml' ) ; Inherited from L. The constructor is called by L. =head2 read ( io_handle => ... ) Of all parameters passed to this read call-back, only C is used. This parameter must be L object already opened for read. It can also be undef. In which case C returns 0. When a file is read, C returns 1. =head2 write ( io_handle => ... ) Of all parameters passed to this write call-back, only C is used. This parameter must be L object already opened for write. C 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-2016 by Dominique Dumont. This is free software, licensed under: The GNU Lesser General Public License, Version 2.1, February 1999 =cut Config-Model-2.097/lib/Config/Model/Backend/ShellVar.pm0000644000175000017500000001217013027007223021055 0ustar domidomi# # This file is part of Config-Model # # This software is Copyright (c) 2005-2016 by Dominique Dumont. # # This is free software, licensed under: # # The GNU Lesser General Public License, Version 2.1, February 1999 # package Config::Model::Backend::ShellVar; $Config::Model::Backend::ShellVar::VERSION = '2.097'; use Carp; use Mouse; use Config::Model::Exception; use File::Path; use Log::Log4perl qw(get_logger :levels); extends 'Config::Model::Backend::Any'; my $logger = get_logger("Backend::ShellVar"); sub suffix { return '.conf'; } sub annotation { return 1; } sub read { my $self = shift; my %args = @_; # args are: # object => $obj, # Config::Model::Node object # root => './my_test', # fake root directory, userd for tests # config_dir => /etc/foo', # absolute path # file => 'foo.conf', # file name # file_path => './my_test/etc/foo/foo.conf' # io_handle => $io # IO::File object # check => yes|no|skip return 0 unless defined $args{io_handle}; # no file to read my $check = $args{check} || 'yes'; my @lines = $args{io_handle}->getlines; # try to get global comments (comments before a blank line) $self->read_global_comments( \@lines, '#' ); my @assoc = $self->associates_comments_with_data( \@lines, '#' ); foreach my $item (@assoc) { my ( $data, $c ) = @$item; $data =~ s/\s*=\s*/=/; # make reader quite tolerant my $load = qq!$data!; $load .= qq!#"$c"! if $c; $logger->debug("Loading:$load\n"); $self->node->load( step => $load, check => $check ); } return 1; } sub write { my $self = shift; my %args = @_; # args are: # object => $obj, # Config::Model::Node object # root => './my_test', # fake root directory, userd for tests # config_dir => /etc/foo', # absolute path # file => 'foo.conf', # file name # file_path => './my_test/etc/foo/foo.conf' # io_handle => $io # IO::File object # check => yes|no|skip my $ioh = $args{io_handle}; my $node = $args{object}; croak "Undefined file handle to write" unless defined $ioh; my @to_write; # Using Config::Model::ObjTreeScanner would be overkill foreach my $elt ( $node->get_element_name ) { my $obj = $node->fetch_element($elt); my $v = $node->grab_value($elt); next unless defined $v; push @to_write, [ qq!$elt="$v"!, $obj->annotation ]; } if (@to_write) { $self->write_global_comment( $ioh, '#' ); map { $self->write_data_and_comments( $ioh, '#', @$_ ); } @to_write; } return 1; } no Mouse; __PACKAGE__->meta->make_immutable; 1; # ABSTRACT: Read and write config as a C data structure __END__ =pod =encoding UTF-8 =head1 NAME Config::Model::Backend::ShellVar - Read and write config as a C data structure =head1 VERSION version 2.097 =head1 SYNOPSIS use Config::Model; my $model = Config::Model->new; $model->create_config_class ( name => "MyClass", element => [ [qw/foo bar/] => {qw/type leaf value_type string/} ], read_config => [ { backend => 'ShellVar', config_dir => '/tmp', file => 'foo.conf', auto_create => 1, } ], ); my $inst = $model->instance(root_class_name => 'MyClass' ); my $root = $inst->config_root ; $root->load('foo=FOO1 bar=BAR1' ); $inst->write_back ; File C now contains: ## This file was written by Config::Model ## You may modify the content of this file. Configuration ## modifications will be preserved. Modifications in ## comments may be mangled. ## foo="FOO1" bar="BAR1" =head1 DESCRIPTION This module is used directly by L to read or write the content of a configuration tree written with C syntax in C configuration tree. Note that undefined values are skipped for list element. I.e. if a list element contains C<('a',undef,'b')>, the data structure contains C<'a','b'>. =head1 CONSTRUCTOR =head2 new ( node => $node_obj, name => 'shellvar' ) ; Inherited from L. The constructor is called by L. =head2 read ( io_handle => ... ) Of all parameters passed to this read call-back, only C is used. This parameter must be L object already opened for read. It can also be undef. In which case C returns 0. When a file is read, C returns 1. =head2 write ( io_handle => ... ) Of all parameters passed to this write call-back, only C is used. This parameter must be L object already opened for write. C 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-2016 by Dominique Dumont. This is free software, licensed under: The GNU Lesser General Public License, Version 2.1, February 1999 =cut Config-Model-2.097/lib/Config/Model/Backend/Json.pm0000644000175000017500000001156113027007223020251 0ustar domidomi# # This file is part of Config-Model # # This software is Copyright (c) 2005-2016 by Dominique Dumont. # # This is free software, licensed under: # # The GNU Lesser General Public License, Version 2.1, February 1999 # package Config::Model::Backend::Json; $Config::Model::Backend::Json::VERSION = '2.097'; use Carp; use strict; use warnings; use Config::Model::Exception; use File::Path; use Log::Log4perl qw(get_logger :levels); use base qw/Config::Model::Backend::Any/; use JSON; my $logger = get_logger("Backend::Json"); sub suffix { return '.json'; } sub read { my $self = shift; my %args = @_; # args is: # object => $obj, # Config::Model::Node object # root => './my_test', # fake root directory, userd for tests # config_dir => /etc/foo', # absolute path # file => 'foo.conf', # file name # file_path => './my_test/etc/foo/foo.conf' # io_handle => $io # IO::File object # check => yes|no|skip return 0 unless defined $args{io_handle}; # no file to read # load Json file my $json = join( '', $args{io_handle}->getlines ); # convert to perl data my $perl_data = decode_json $json ; if ( not defined $perl_data ) { $logger->warn("No data found in Json file $args{file_path}"); return 1; } # load perl data in tree $self->{node}->load_data( data => $perl_data, check => $args{check} || 'yes' ); return 1; } sub write { my $self = shift; my %args = @_; # args is: # object => $obj, # Config::Model::Node object # root => './my_test', # fake root directory, userd for tests # config_dir => /etc/foo', # absolute path # file => 'foo.conf', # file name # file_path => './my_test/etc/foo/foo.conf' # io_handle => $io # IO::File object # check => yes|no|skip croak "Undefined file handle to write" unless defined $args{io_handle}; my $perl_data = $self->{node}->dump_as_data( full_dump => $args{full_dump} ); my $json = to_json( $perl_data, { pretty => 1 } ); $args{io_handle}->print($json); return 1; } 1; # ABSTRACT: Read and write config as a JSON data structure __END__ =pod =encoding UTF-8 =head1 NAME Config::Model::Backend::Json - Read and write config as a JSON data structure =head1 VERSION version 2.097 =head1 SYNOPSIS use Config::Model ; use Data::Dumper ; # define configuration tree object my $model = Config::Model->new ; $model ->create_config_class ( name => "MyClass", element => [ [qw/foo bar/] => { type => 'leaf', value_type => 'string' }, baz => { type => 'hash', index_type => 'string' , cargo => { type => 'leaf', value_type => 'string', }, }, ], read_config => [ { backend => 'Json' , config_dir => '/tmp', file => 'foo.json', auto_create => 1, } ], ) ; my $inst = $model->instance(root_class_name => 'MyClass' ); my $root = $inst->config_root ; my $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 ( node => $node_obj, name => 'Json' ) ; Inherited from L. The constructor is called by L. =head2 read ( io_handle => ... ) Of all parameters passed to this read call-back, only C is used. This parameter must be an 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 ( io_handle => ... ) Of all parameters passed to this write call-back, only C is used. This parameter must be L object already opened for write. C 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-2016 by Dominique Dumont. This is free software, licensed under: The GNU Lesser General Public License, Version 2.1, February 1999 =cut Config-Model-2.097/lib/Config/Model/Backend/PlainFile.pm0000644000175000017500000001531713027007223021206 0ustar domidomi# # This file is part of Config-Model # # This software is Copyright (c) 2005-2016 by Dominique Dumont. # # This is free software, licensed under: # # The GNU Lesser General Public License, Version 2.1, February 1999 # package Config::Model::Backend::PlainFile; $Config::Model::Backend::PlainFile::VERSION = '2.097'; use Carp; use Mouse; use Config::Model::Exception; use File::Path; use Log::Log4perl qw(get_logger :levels); extends 'Config::Model::Backend::Any'; my $logger = get_logger("Backend::PlainFile"); sub suffix { return ''; } sub annotation { return 0; } sub skip_open { 1; } sub read { my $self = shift; my %args = @_; # args are: # object => $obj, # Config::Model::Node object # root => './my_test', # fake root directory, userd for tests # config_dir => /etc/foo', # absolute path # file => 'foo.conf', # file name # file_path => './my_test/etc/foo/foo.conf' # io_handle => $io # IO::File object # check => yes|no|skip my $check = $args{check} || 'yes'; my $dir = $args{config_dir}; my $node = $args{object}; $logger->debug( "called on node", $node->name ); # read data from leaf element from the node foreach my $elt ( $node->get_element_name() ) { my $file = $args{root} . $dir . $elt; $logger->trace("looking for plainfile $file"); my $obj = $args{object}->fetch_element( name => $elt ); my $type = $obj->get_type; if ( $type eq 'leaf' ) { $self->read_leaf( $obj, $elt, $check, $file, \%args ); } elsif ( $type eq 'list' ) { $self->read_list( $obj, $elt, $check, $file, \%args ); } elsif ( $type eq 'hash' ) { $self->read_hash( $obj, $elt, $check, $file, \%args ); } else { $logger->debug("PlainFile read skiped $type $elt"); } } return 1; } # # New subroutine "open_for_read" extracted - Thu Jul 21 13:36:52 2011. # sub open_for_read { my ( $self, $file, $elt ) = @_; return unless -e $file; my $fh = new IO::File; $fh->open($file) or die "Cannot open $file:$!"; $fh->binmode(":utf8"); $logger->trace("found file $file for element $elt"); return ($fh); } # # New subroutine "read_leaf" extracted - Thu Jul 21 12:58:06 2011. # sub read_leaf { my ( $self, $obj, $elt, $check, $file, $args ) = @_; my $fh = $self->open_for_read( $file, $elt ) or return; my $v = join( '', $fh->getlines ); chomp $v unless $obj->value_type eq 'string'; $obj->store( value => $v, check => $check ); } # # New subroutine "read_list" extracted - Thu Jul 21 12:58:36 2011. # sub read_list { my ( $self, $obj, $elt, $check, $file, $args ) = @_; my $fh = $self->open_for_read( $file, $elt ) or return; my @v = $fh->getlines; chomp @v; $obj->store_set(@v); } # # New subroutine "read_hash" extracted - Thu Jul 21 12:58:50 2011. # sub read_hash { my ( $self, $obj, $elt, $check, $file, $args ) = @_; $logger->debug("PlainFile read skipped hash $elt"); } sub write { my $self = shift; my %args = @_; # args are: # object => $obj, # Config::Model::Node object # root => './my_test', # fake root directory, userd for tests # config_dir => /etc/foo', # absolute path read # file => 'foo.conf', # file name # file_path => './my_test/etc/foo/foo.conf' # io_handle => $io # IO::File object # check => yes|no|skip my $check = $args{check} || 'yes'; my $dir = $args{root} . $args{config_dir}; mkpath( $dir, { mode => 0755 } ) unless -d $dir; my $node = $args{object}; $logger->debug( "PlainFile write called on node ", $node->name ); # write data from leaf element from the node foreach my $elt ( $node->get_element_name() ) { my $file = $dir . $elt; my $obj = $args{object}->fetch_element( name => $elt ); my $type = $obj->get_type; my @v; if ( $type eq 'leaf' ) { $v[0] = $obj->fetch( check => $args{check} ); $v[0] .= "\n" unless $obj->value_type eq 'string'; } elsif ( $type eq 'list' ) { @v = map { "$_\n" } $obj->fetch_all_values; } else { $logger->debug("PlainFile write skipped $type $elt"); } if (@v) { $logger->trace("PlainFile write opening $file to write"); my $fh = new IO::File; $fh->open( $file, '>' ) or die "Cannot open $file:$!"; $fh->binmode(":utf8"); $fh->print(@v); $fh->close; } } return 1; } no Mouse; __PACKAGE__->meta->make_immutable; 1; # ABSTRACT: Read and write config as plain file __END__ =pod =encoding UTF-8 =head1 NAME Config::Model::Backend::PlainFile - Read and write config as plain file =head1 VERSION version 2.097 =head1 SYNOPSIS use Config::Model; my $model = Config::Model->new; my $inst = $model->create_config_class( name => "WithPlainFile", element => [ [qw/source new/] => { qw/type leaf value_type uniline/ }, ], read_config => [ { backend => 'plain_file', config_dir => '/tmp', }, ], ); my $inst = $model->instance(root_class_name => 'WithPlainFile' ); my $root = $inst->config_root ; $root->load('source=foo new=yes' ); $inst->write_back ; Now C directory 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. This module supports currently only leaf and list elements. In the case of C element, each line of the file is a value of the list. =head1 Methods =head2 read_leaf (obj,elt,check,file,args); Called by L method to read the file of a leaf element. C contains the arguments passed to L method. =head2 read_hash (obj,elt,check,file,args); Like L for hash elements. =head2 read_list (obj,elt,check,file,args); Like L for list elements. =head2 write ( ) C 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-2016 by Dominique Dumont. This is free software, licensed under: The GNU Lesser General Public License, Version 2.1, February 1999 =cut Config-Model-2.097/lib/Config/Model/Backend/Fstab.pm0000644000175000017500000001447113027007223020402 0ustar domidomi# # This file is part of Config-Model # # This software is Copyright (c) 2005-2016 by Dominique Dumont. # # This is free software, licensed under: # # The GNU Lesser General Public License, Version 2.1, February 1999 # package Config::Model::Backend::Fstab; $Config::Model::Backend::Fstab::VERSION = '2.097'; use Mouse; use Carp; use Log::Log4perl qw(get_logger :levels); extends 'Config::Model::Backend::Any'; my $logger = get_logger("Backend::Fstab"); sub suffix { return ''; } sub annotation { return 1; } my %opt_r_translate = ( ro => 'rw=0', rw => 'rw=1', bsddf => 'statfs_behavior=bsddf', minixdf => 'statfs_behavior=minixdf', ); sub read { my $self = shift; my %args = @_; # args are: # root => './my_test', # fake root directory, userd for tests # config_dir => /etc/foo', # absolute path # file => 'foo.conf', # file name # file_path => './my_test/etc/foo/foo.conf' # io_handle => $io # IO::File object # check => yes|no|skip return 0 unless defined $args{io_handle}; # no file to read my $check = $args{check} || 'yes'; my @lines = $args{io_handle}->getlines; # try to get global comments (comments before a blank line) $self->read_global_comments( \@lines, '#' ); my @assoc = $self->associates_comments_with_data( \@lines, '#' ); foreach my $item (@assoc) { my ( $data, $comment ) = @$item; $logger->trace("fstab read data '$data' comment '$comment'"); my ( $device, $mount_point, $type, $options, $dump, $pass ) = split /\s+/, $data; my $swap_idx = 0; my $label = $device =~ /LABEL=(\w+)$/ ? $1 : $type eq 'swap' ? "swap-" . $swap_idx++ : $mount_point; my $fs_obj = $self->node->fetch_element('fs')->fetch_with_id($label); if ($comment) { $logger->debug("Annotation: $comment\n"); $fs_obj->annotation($comment); } my $load_line = "fs_vfstype=$type fs_spec=$device fs_file=$mount_point " . "fs_freq=$dump fs_passno=$pass"; $logger->debug("Loading:$load_line\n"); $fs_obj->load( step => $load_line, check => $check ); # now load fs options $logger->trace("fs_type $type options is $options"); my @options = split /,/, $options; map { $_ = $opt_r_translate{$_} if defined $opt_r_translate{$_}; s/no(.*)/$1=0/; $_ .= '=1' unless /=/; } @options; $logger->debug("Loading:@options"); $fs_obj->fetch_element('fs_mntopts')->load( step => "@options", check => $check ); } return 1; } sub write { my $self = shift; my %args = @_; # args are: # object => $obj, # Config::Model::Node object # root => './my_test', # fake root directory, userd for tests # config_dir => /etc/foo', # absolute path # file => 'foo.conf', # file name # file_path => './my_test/etc/foo/foo.conf' # io_handle => $io # IO::File object # check => yes|no|skip my $ioh = $args{io_handle}; my $node = $args{object}; croak "Undefined file handle to write" unless defined $ioh; $self->write_global_comment( $ioh, '#' ); # Using Config::Model::ObjTreeScanner would be overkill foreach my $line_obj ( $node->fetch_element('fs')->fetch_all ) { my $d = sprintf( "%-30s %-25s %-6s %-10s %d %d\n", map ( $line_obj->fetch_element_value($_), qw/fs_spec fs_file fs_vfstype/ ), $self->option_string( $line_obj->fetch_element('fs_mntopts') ), map ( $line_obj->fetch_element_value($_), qw/fs_freq fs_passno/ ), ); $self->write_data_and_comments( $ioh, '#', $d, $line_obj->annotation ); } return 1; } my %rev_opt_r_translate = reverse %opt_r_translate; sub option_string { my ( $self, $obj ) = @_; my @options; foreach my $opt ( $obj->get_element_name ) { my $v = $obj->fetch_element_value($opt); next unless defined $v; my $key = "$opt=$v"; my $str = defined $rev_opt_r_translate{$key} ? $rev_opt_r_translate{$key} : "$v" eq '0' ? 'no' . $opt : "$v" eq '1' ? $opt : $key; push @options, $str; } return join ',', @options; } no Mouse; __PACKAGE__->meta->make_immutable; 1; # ABSTRACT: Read and write config from fstab file __END__ =pod =encoding UTF-8 =head1 NAME Config::Model::Backend::Fstab - Read and write config from fstab file =head1 VERSION version 2.097 =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 ( node => $node_obj, name => 'fstab' ) ; Inherited from L. The constructor is called by L. =head2 read ( io_handle => ... ) Of all parameters passed to this read call-back, only C is used. This parameter must be L object already opened for read. It can also be undef. In this case, C returns 0. When a file is read, C returns 1. =head2 write ( io_handle => ... ) Of all parameters passed to this write call-back, only C is used. This parameter must be L object already opened for write. C 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-2016 by Dominique Dumont. This is free software, licensed under: The GNU Lesser General Public License, Version 2.1, February 1999 =cut Config-Model-2.097/lib/Config/Model/WarpedNode.pm0000644000175000017500000003573213027007223020047 0ustar domidomi# # This file is part of Config-Model # # This software is Copyright (c) 2005-2016 by Dominique Dumont. # # This is free software, licensed under: # # The GNU Lesser General Public License, Version 2.1, February 1999 # package Config::Model::WarpedNode; $Config::Model::WarpedNode::VERSION = '2.097'; 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/; 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 has_element is_element_available element_type load fetch_element_value get_type get_cargo_type dump_tree describe get_help get_help_as_text children get set accept_regexp/ ) { # to register new methods in package no strict "refs"; *$method = sub { my $self = shift; # return undef if no class was warped in $self->check or return undef; return $self->{data}->$method(@_); }; } sub name { my $self = shift; return $self->location; } sub is_accessible { my $self = shift; return defined $self->{data} ? 1 : 0; } sub get_actual_node { my $self = shift; $self->check; return $self->{data}; # might be undef } sub check { my $self = shift; my $check = shift || 'yes '; # must croak if element is not available if ( not defined $self->{data} ) { # a node can be retrieved either for a store operation or for # a fetch. if ( $check eq 'yes' ) { Config::Model::Exception::User->throw( object => $self, message => "Object '$self->{element_name}' is not accessible.\n\t" . $self->warp_error ); } else { return 0; } } return 1; } sub set_properties { my $self = shift; my %args = ( %{ $self->backup }, @_ ); # mega cleanup map( delete $self->{$_}, @allowed_warp_params ); $logger->debug( $self->name . " set_properties called with ", Data::Dumper->Dump( [ \%args ], ['set_properties_args'] ) ); my $config_class_name = delete $args{config_class_name}; my $node_class = delete $args{class} || 'Config::Model::Node'; my @prop_args = ( qw/property level element/, $self->element_name ); my $original_level = $self->config_model->get_element_property( class => $self->parent->config_class_name, @prop_args, ); my $next_level = defined $args{level} ? $args{level} : defined $config_class_name ? $original_level : 'hidden'; $self->parent->set_element_property( @prop_args, value => $next_level ) unless defined $self->index_value; unless ( defined $config_class_name ) { $self->clear; return; } my @args; ( $config_class_name, @args ) = @$config_class_name if ref $config_class_name; # check if some action is needed (ie. create or morph node) return if defined $self->{config_class_name} and $self->{config_class_name} eq $config_class_name; my $old_object = $self->{data}; my $old_config_class_name = $self->{config_class_name}; # create a new object from scratch my $new_object = $self->create_node( $config_class_name, @args ); $self->{config_class_name} = $config_class_name; $self->{data} = $new_object; if ( defined $old_object and $self->{morph} ) { # there an old object that we need to translate $logger->debug( "WarpedNode: morphing ", $old_object->name, " to ", $new_object->name ) if $logger->is_debug; $new_object->copy_from( from => $old_object, check => 'skip' ); } # bringing a new object does not really modify the content of the config tree. # only changes underneath 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 ) { 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.097 =head1 SYNOPSIS use Config::Model; my $model = Config::Model->new; foreach (qw/X Y/) { $model->create_config_class( name => "Class$_", element => [ foo => {qw/type leaf value_type string/} ] ); } $model->create_config_class( name => "MyClass", element => [ master_switch => { type => 'leaf', value_type => 'enum', choice => [qw/cX cY/] }, 'a_warped_node' => { type => 'warped_node', follow => { ms => '! master_switch' }, rules => [ '$ms eq "cX"' => { config_class_name => 'ClassX' }, '$ms eq "cY"' => { config_class_name => 'ClassY' }, ] }, ], ); my $inst = $model->instance(root_class_name => 'MyClass' ); my $root = $inst->config_root ; print "Visible elements: ",join(' ',$root->get_element_name),"\n" ; # Visible elements: master_switch $root->load( 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 ( 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-2016 by Dominique Dumont. This is free software, licensed under: The GNU Lesser General Public License, Version 2.1, February 1999 =cut Config-Model-2.097/lib/Config/Model/Manual/0000755000175000017500000000000013027007223016664 5ustar domidomiConfig-Model-2.097/lib/Config/Model/Manual/ModelCreationIntroduction.pod0000644000175000017500000006317613027007223024534 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.097 =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