Config-Model-TkUI-1.365/0000755000175000017500000000000013204357016013250 5ustar domidomiConfig-Model-TkUI-1.365/MANIFEST0000644000175000017500000000255413204357016014407 0ustar domidomi# This file was automatically generated by Dist::Zilla::Plugin::Manifest v6.010. Build.PL Changes LICENSE MANIFEST MANIFEST.SKIP META.json META.yml README examples/model.pl lib/Config/Model/Tk/AnyViewer.pm lib/Config/Model/Tk/CheckListEditor.pm lib/Config/Model/Tk/CheckListViewer.pm lib/Config/Model/Tk/HashEditor.pm lib/Config/Model/Tk/HashViewer.pm lib/Config/Model/Tk/LeafEditor.pm lib/Config/Model/Tk/LeafViewer.pm lib/Config/Model/Tk/ListEditor.pm lib/Config/Model/Tk/ListViewer.pm lib/Config/Model/Tk/NodeEditor.pm lib/Config/Model/Tk/NodeViewer.pm lib/Config/Model/Tk/NoteEditor.pm lib/Config/Model/Tk/Wizard.pm lib/Config/Model/Tk/icons/add.png lib/Config/Model/Tk/icons/dbgrun.png lib/Config/Model/Tk/icons/dialog-warning.png lib/Config/Model/Tk/icons/down.png lib/Config/Model/Tk/icons/eraser.png lib/Config/Model/Tk/icons/fontsizeup.png lib/Config/Model/Tk/icons/gnome-next.png lib/Config/Model/Tk/icons/gnome-previous.png lib/Config/Model/Tk/icons/next.png lib/Config/Model/Tk/icons/remove.png lib/Config/Model/Tk/icons/rotate_cw.png lib/Config/Model/Tk/icons/stop.png lib/Config/Model/Tk/icons/tools_nicu_buculei_01.png lib/Config/Model/Tk/icons/up.png lib/Config/Model/Tk/icons/viewmag.png lib/Config/Model/Tk/icons/wizard.png lib/Config/Model/TkUI.pm t/author-pod-syntax.t t/config-model-ui.t t/config-model-wizard.t t/lib/Config/Model/models/Master.pl t/pod.t weaver.ini Config-Model-TkUI-1.365/LICENSE0000644000175000017500000006013213204357016014257 0ustar domidomiThis software is Copyright (c) 2008-2017 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-TkUI-1.365/t/0000755000175000017500000000000013204357016013513 5ustar domidomiConfig-Model-TkUI-1.365/t/config-model-ui.t0000644000175000017500000002036313204357016016662 0ustar domidomi# -*- cperl -*- use warnings FATAL => qw(all); use ExtUtils::testlib; use Test::More ; use Test::Warn 0.11; use Tk; use Config::Model::TkUI; use Config::Model ; use Log::Log4perl qw(:easy) ; use strict; use lib 't/lib'; sub test_all { my ($mw, $delay,$test_ref) = @_ ; my $test = shift @$test_ref ; $test->() ; $mw->after($delay, sub { test_all($mw, $delay,$test_ref) } ) if @$test_ref; } 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|i/; print "You can play with the widget if you run the test with 's' argument\n"; 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"); my $model = Config::Model -> new () ; my $cmu ; my $inst = $model->instance ( root_class_name => 'Master', instance_name => 'test1', root_dir => 'wr_data', on_message_cb => sub { $cmu->show_message(@_) ;} ); ok($inst,"created dummy instance") ; my $root = $inst -> config_root ; ok($root,"Config root created") ; my $step = qq! #"class comment\nbig\nreally big" std_id#"std_id comment" 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#"big lever here" a_string="utf8 smiley \x{263A}" a_long_string="a very long string with\nembedded return" hash_a:toto=toto_value hash_a:toto#"index comment" hash_a:titi=titi_value hash_a:"ti ti"="ti ti value" ordered_hash:z=1 ordered_hash:y=2 ordered_hash:x=3 ordered_hash_of_nodes:N1 X=Av - ordered_hash_of_nodes:N2 X=Bv - lista=a,b,c,d olist:0 X=Av - olist:1 X=Bv - my_ref_check_list=toto my_reference="titi" my_plain_check_list=AA,AC warp warp2 aa2="foo bar" !; $step .= '! a_very_long_string=~"s/\s*general\s*/ /ig"'; ok( $root->load( step => $step ), "set up data in tree"); my $load_fix = "a_mandatory_string=foo1 another_mandatory_string=foo2 ordered_hash_of_mandatory:foo=hashfoo warp a_string=warpfoo a_long_string=longfoo another_string=anotherfoo - slave_y a_string=slave_y_foo a_long_string=sylongfoo another_string=sy_anotherfoo" ; #$root->load(step => "tree_macro=XZ") ; $root->fetch_element('ordered_hash_of_mandatory')->fetch_with_id('foo') ; # use Tk::ObjScanner; Tk::ObjScanner::scan_object($root) ; # eval this and skip test in case of failure. SKIP: { my $mw = eval {MainWindow-> new ; }; # cannot create Tk window skip "Cannot create Tk window",1 unless $mw; $mw->withdraw ; $cmu = $mw->ConfigModelUI (-root => $root, ) ; my $delay = 200 ; my $tktree= $cmu->Subwidget('tree') ; my $mgr = $cmu->Subwidget('multi_mgr') ; my $widget ; # ugly global variable. Use with care my $idx = 1 ; my @test = ( sub { $cmu->reload ; ok(1,"forced test: reload") } , ) ; push @test, sub { $cmu->create_element_widget('edit','test1'); ok(1,"test ".$idx++)}, sub { $inst->show_message("Hello World")}, sub { $cmu->force_element_display($root->grab('std_id:dd DX')) ; ok(1,"test ".$idx++)}, sub { $cmu->edit_copy('test1.std_id'); ok(1,"test ".$idx++)}, sub { $cmu->force_element_display($root->grab('hash_a:titi')) ; ok(1,"test ".$idx++)}, sub { $cmu->edit_copy('test1.hash_a.titi'); ok(1,"test ".$idx++)}, sub { $cmu->create_element_widget('view','test1'); ok(1,"test ".$idx++)}, sub { $tktree->open('test1.lista') ; ok(1,"test ".$idx++)}, sub { $cmu->create_element_widget('edit','test1.std_id');; ok(1,"test ".$idx++)}, sub { $cmu->{editor}->add_entry('e'); ok(1,"test ".$idx++)}, sub { $tktree->open('test1.std_id') ; ok(1,"test ".$idx++)}, sub { $cmu->reload; ok(1,"test reload ".$idx++)} , sub { $cmu->create_element_widget('view','test1.std_id'); ok(1,"test ".$idx++)}, sub { $inst->show_message("Hello again World")}, sub { $cmu->create_element_widget('edit','test1.std_id'); ok(1,"test ".$idx++)}, sub { $tktree->open('test1.std_id.ab') ; ok(1,"test ".$idx++)}, sub { $cmu->create_element_widget('view','test1.std_id.ab.Z'); ok(1,"test ".$idx++)}, sub { $root->load(step => "std_id:ab Z=Cv") ; $cmu->reload ;; ok(1,"test load ".$idx++)}, sub { $tktree->open('test1.std_id.ab') ; ok(1,"test ".$idx++)}, sub { $cmu->create_element_widget('edit','test1.std_id.ab.DX'); ok(1,"test ".$idx++)}, sub { $root->load(step => "std_id:ab3") ; $cmu->reload ;; ok(1,"test load ".$idx++)} , sub { $cmu->create_element_widget('view','test1.a_very_long_string'); ok(1,"test diff view ".$idx++)}, sub { $cmu->create_element_widget('view','test1.string_with_def'); ok(1,"test ".$idx++)}, sub { $cmu->create_element_widget('edit','test1.string_with_def'); ok(1,"test ".$idx++)}, sub { $cmu->create_element_widget('view','test1.a_long_string'); ok(1,"test ".$idx++)}, sub { $cmu->create_element_widget('edit','test1.a_long_string'); ok(1,"test ".$idx++)}, sub { $cmu->create_element_widget('view','test1.int_v'); ok(1,"test ".$idx++)}, sub { $cmu->create_element_widget('edit','test1.int_v'); ok(1,"test ".$idx++)}, sub { $cmu->create_element_widget('view','test1.my_plain_check_list'); ok(1,"test ".$idx++)}, sub { $cmu->create_element_widget('edit','test1.my_plain_check_list'); ok(1,"test ".$idx++)}, sub { $cmu->create_element_widget('view','test1.my_ref_check_list'); ok(1,"test ".$idx++)}, sub { $cmu->create_element_widget('edit','test1.my_ref_check_list'); ok(1,"test ".$idx++)}, sub { $cmu->create_element_widget('view','test1.my_reference'); ok(1,"test ".$idx++)}, sub { $cmu->create_element_widget('edit','test1.my_reference'); ok(1,"test ".$idx++)}, sub { my $name = "check_list_with_upstream_default"; my $clwud = $root->grab(step => $name) ; $cmu->force_element_display($clwud); ok(1,"show check list with upstream value ".$idx++)} , sub { my $name = "check_list_with_upstream_default"; my $clwud = $root->grab(step => $name) ; my @set = $clwud->get_choice; $clwud->check(@set); $cmu->force_element_display($clwud); ok(1,"test check list with upstream data ".$idx++)} , sub { $root->load(step => "ordered_checklist=A,Z,G") ; $cmu->reload ;; ok(1,"test load ".$idx++)} , sub { $widget = $cmu->create_element_widget('edit','test1.ordered_checklist'); ok(1,"test ".$idx++)}, sub { $widget->Subwidget('notebook')->raise('order') ;; ok(1,"test notebook raise 1 ".$idx++)}, sub { $widget->Subwidget('notebook')->raise('order') ;; ok(1,"test notebook raise 2 ".$idx++)}, sub { $widget->{order_list}->selectionSet(1,1) ;; ok(1,"test selectionSet ".$idx++)}, # Z sub { $widget->move_selected_down ; ok(1,"test move_selected_down ".$idx++)}, # cannot save with pending errors sub { $cmu->save(); ok(1,"test save 1 ".$idx++)}, sub { #for ($cmu->children) { $_->destroy if $_->name =~ /dialog/i; } ; $root->load($load_fix);; ok(1,"test load_fix ".$idx++)}, sub { $cmu->save(); ok(1,"test save 2 ".$idx++)}, sub { $cmu->create_element_widget('edit','test1.always_warn'); $cmu -> force_element_display($root->grab('always_warn')) ; ; ok(1,"test always_warn ".$idx++)}, # warn test, 3 warnings: load, fetch for hlist, fetch for editor sub { warnings_like { $root->load("always_warn=foo") ; $cmu->reload ;} [ ( qr/always/ ) x 2 ] ,"warn test always_warn 2 ".$idx++ ; }, sub { $root->load('always_warn~') ; $cmu->reload ;; ok(1,"test remove always_warn ".$idx++)}, sub { $cmu->create_element_widget('edit','test1.warn_unless'); $cmu -> force_element_display($root->grab('warn_unless')) ; ok(1,"test warn_unless ".$idx++); }, sub { warnings_like { $root->load("warn_unless=bar") ; $cmu->reload ;} [ ( qr/warn_unless/ ) x 2 ] ,"warn test warn_unless ".$idx++ ; }, sub { $root->load('warn_unless=foo2') ; $cmu->reload ;; ok(1,"test fix warn_unless ".$idx++)}, sub { $cmu ->show_changes ; ok(1,"test show_changes ".$idx++)} , sub { $mw->destroy; }, unless $show; test_all($mw , $delay, \@test) ; ok(1,"window launched") ; # $mw->WidgetDump ; MainLoop ; # Tk's } ok(1,"All tests are done"); done_testing; Config-Model-TkUI-1.365/t/pod.t0000644000175000017500000000023713204357016014464 0ustar domidomi# -*- cperl -*- use strict; use Test::More; eval "use Test::Pod 1.00"; plan skip_all => "Test::Pod 1.00 required for testing POD" if $@; all_pod_files_ok( ); Config-Model-TkUI-1.365/t/config-model-wizard.t0000644000175000017500000000553213204357016017546 0ustar domidomi# -*- cperl -*- use warnings FATAL => qw(all); use ExtUtils::testlib; use Test::More ; use Tk; use Config::Model::TkUI; use Config::Model ; use Config::Model::Value ; use Log::Log4perl qw(get_logger :levels) ; use Test::Memory::Cycle; use strict; use lib 't/lib'; 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|i/; print "You can play with the widget if you run the test with 's' argument\n"; my $home = $ENV{HOME} || ''; my $log4perl_user_conf_file = "$home/.log4config-model"; if (-r $log4perl_user_conf_file) { Log::Log4perl::init($log4perl_user_conf_file); } else { Log::Log4perl->easy_init($log ? $TRACE: $WARN); } Config::Model::Exception::Any->Trace(1) if $arg =~ /e/; ok(1,"Compilation done"); my $model = Config::Model -> new () ; my $inst = $model->instance ( root_class_name => 'Master', instance_name => 'test1', root_dir => 'wr_data', ); ok($inst,"created dummy instance") ; my $root = $inst -> config_root ; ok($root,"Config root created") ; $Config::Model::Value::nowarning=1; my $step = qq! warn_unless=qwerty 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 a_string="toto tata" a_long_string="a very long string with\nembedded return" 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 ordered_hash_of_nodes:N1 X=Av - ordered_hash_of_nodes:N2 X=Bv - lista=a,b,c,d olist:0 X=Av - olist:1 X=Bv - my_ref_check_list=toto my_reference="titi" my_plain_check_list=AA,AC warp warp2 aa2="foo bar" !; ok( $root->load( step => $step ), "set up data in tree"); # use Tk::ObjScanner; Tk::ObjScanner::scan_object($root) ; my $toto ; # TBD eval this and skip test in case of failure. SKIP: { my $mw = eval {MainWindow-> new ; }; # cannot create Tk window skip "Cannot create Tk window",1 if $@; $mw->withdraw ; my $cmw = $mw->ConfigModelWizard (-root => $root, -store_cb => sub{}, ) ; my $delay = 1000 ; sub inc_d { $delay += 500 } ; my @test ; foreach (1 .. 4 ) { push @test, sub {$cmw->{keep_wiz_editor} = 0 ; $cmw->{wizard}->go_forward; } ; } foreach (1 .. 2 ) { push @test, sub {$cmw->{keep_wiz_editor} = 0 ; $cmw->{wizard}->go_backward;} ; } # no problem if too many subs are defined: programs will exit foreach (1 .. 100 ) { push @test, sub {$cmw->{keep_wiz_editor} = 0 ; $cmw->{wizard}->go_forward; } ; } unless ($show) { foreach my $t (@test) { $mw->after($delay, $t); inc_d ; } } $cmw->start_wizard('master',1) ; ok(1,"wizard done") ; memory_cycle_ok($cmw); } done_testing; Config-Model-TkUI-1.365/t/lib/0000755000175000017500000000000013204357016014261 5ustar domidomiConfig-Model-TkUI-1.365/t/lib/Config/0000755000175000017500000000000013204357016015466 5ustar domidomiConfig-Model-TkUI-1.365/t/lib/Config/Model/0000755000175000017500000000000013204357016016526 5ustar domidomiConfig-Model-TkUI-1.365/t/lib/Config/Model/models/0000755000175000017500000000000013204357016020011 5ustar domidomiConfig-Model-TkUI-1.365/t/lib/Config/Model/models/Master.pl0000644000175000017500000003275313204357016021613 0ustar domidomi# -*- cperl -*- # # This file is part of Config-Model-TkUI # # This software is Copyright (c) 2008-2017 by Dominique Dumont. # # This is free software, licensed under: # # The GNU Lesser General Public License, Version 2.1, February 1999 # use utf8; # 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 => 'uniline' }, 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', gist => 'Z:{Z} DX:{DX}', 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', }, [qw/a_string a_long_string another_string/] => { type => 'leaf', mandatory => 1, value_type => 'string' }, warp2 => { type => 'warped_node', follow => '! tree_macro', config_class_name => 'SubSlave', morph => 1, rules => [ mXY => { config_class_name => 'SubSlave2' }, XZ => { config_class_name => 'SubSlave2' } ] }, Y => { type => 'leaf', value_type => 'enum', choice => [qw/Av Bv Cv/] }, ], include => 'X_base_class', ], [ name => 'Master', class_description => " =head1 coucou Master description . Let's go for a very long description with utf8 chars: ßéè. Big class to do: =over =item * shiny =item * beautiful =back things. ", level => [ [qw/lista hash_a tree_macro int_v/] => 'important' ], write_config => [ { backend => 'cds_file', config_dir => '/foo', auto_create => 1 }, ], accept => [ 'foo.*' => { type => 'leaf', value_type => 'uniline'} ], element => [ tree_macro => { type => 'leaf', value_type => 'enum', choice => [qw/XY XZ mXY/], help => { XY => 'XY help', XZ => 'XZ help', mXY => 'mXY help', } }, pop_in_out => { type => 'leaf', level => 'hidden', value_type => 'uniline', default => 'yada yada', warp => { follow => '! tree_macro', rules => [ XZ => { level => 'normal' }, ], }, }, std_id => { type => 'hash', index_type => 'string', cargo => { type => 'node', config_class_name => 'SlaveZ' }, }, [qw/lista listb/] => { type => 'list', cargo => { type => 'leaf', value_type => 'uniline' }, summary => 'lista and listb are used to yada yada with utf8 chars: ßéè', }, [qw/hash_a hash_b/] => { type => 'hash', index_type => 'string', cargo => { type => 'leaf', value_type => 'uniline' }, }, ordered_hash => { type => 'hash', index_type => 'string', ordered => 1, cargo => { type => 'leaf', value_type => 'uniline' }, }, ordered_hash_of_mandatory => { type => 'hash', index_type => 'string', ordered => 1, cargo => { type => 'leaf', value_type => 'uniline', mandatory => 1, }, }, 'ordered_hash_of_nodes' => { type => 'hash', index_type => 'string', ordered => 1, cargo => { type => 'node', config_class_name => 'SlaveZ' }, }, olist => { type => 'list', cargo => { type => 'node', config_class_name => 'SlaveZ', }, }, enum_list => { type => 'list', cargo => { type => 'leaf', value_type => 'enum', choice => [qw/A B C/], } }, "list_with_warn_duplicates" => { type => 'list', duplicates => 'warn' , cargo => { type => 'leaf', value_type => 'string' } }, "hash_with_warn_duplicates" => { type => 'hash', index_type => 'string', duplicates => 'warn' , cargo => { type => 'leaf', value_type => 'string' } }, warp => { type => 'warped_node', follow => '! tree_macro', config_class_name => 'SlaveY', morph => 1, rules => [ #XY => { config_class_name => 'SlaveY'}, mXY => { config_class_name => 'SlaveY' }, XZ => { config_class_name => 'SlaveZ' } ] }, 'slave_y' => { type => 'node', config_class_name => 'SlaveY', }, string_with_def => { type => 'leaf', value_type => 'uniline', default => 'yada yada' }, a_uniline => { type => 'leaf', value_type => 'uniline', default => 'yada yada' }, a_boolean => { type => 'leaf', value_type => 'boolean', }, [qw/a_string a_long_string another_string/] => { type => 'leaf', value_type => 'string' }, [qw/a_very_long_string/] => { type => 'leaf', value_type => 'string', default => " This program is free software; you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by the Free Software Foundation; either version 2.1 of the License, or (at your option) any later version. On Debian GNU/Linux systems, the complete text of version 2.1 of the GNU Lesser General Public License can be found in `/usr/share/common-licenses/LGPL-2.1'" }, [qw/a_mandatory_string another_mandatory_string/] => { type => 'leaf', mandatory => 1, value_type => 'string' }, int_v => { type => 'leaf', value_type => 'integer', default => '10', min => 5, max => 15 }, upstream_default => { type => 'leaf', value_type => 'integer', upstream_default => '10', }, my_plain_check_list => { type => 'check_list', choice => [ 'AA' .. 'AE' ], help => { AA => 'AA help', AC => 'AC help', AE => 'AE help', }, description => 'my_plain_check_list nto so helpfull description', }, enum_with_help => { type => 'leaf', value_type => 'enum' , choice => [ 'AA' .. 'AE' ], help => { map { ( $_ => "$_ help with utf8 ßé²") ;} ('AA' .. 'AE') }, description => 'my_plain_check_list nto so helpfull description', }, enum_with_help_and_long_desc => { type => 'leaf', value_type => 'enum' , choice => [ 'AA' .. 'AE' ], help => { map { ( $_ => "$_ help with utf8 ßé²") ;} ('AA' .. 'AE') } , description => "my_plain_check_list not so helpful\n even if B description 😁", }, my_ref_check_list => { type => 'check_list', refer_to => '- hash_a + ! hash_b', }, 'ordered_checklist' => { type => 'check_list', choice => [ 'A' .. 'Z' ], ordered => 1, help => { A => 'A help', E => 'E help' }, summary => 'will checklist be served ? ;-) ', }, 'check_list_with_upstream_default', => { # from OpenSsh Ssh model (KexAlgorithms) 'choice' => [ 'ecdh-sha2-nistp256', 'ecdh-sha2-nistp384', 'ecdh-sha2-nistp521', 'diffie-hellman-group-exchange-sha256', 'diffie-hellman-group-exchange-sha1', 'diffie-hellman-group14-sha1', 'diffie-hellman-group1-sha1' ], 'description' => 'Specifies the available KEX (Key Exchange) algorithms.', 'type' => 'check_list', 'upstream_default_list' => [ 'diffie-hellman-group-exchange-sha1', 'diffie-hellman-group-exchange-sha256', 'diffie-hellman-group1-sha1', 'diffie-hellman-group14-sha1', 'ecdh-sha2-nistp256', 'ecdh-sha2-nistp384', 'ecdh-sha2-nistp521' ] }, my_reference => { type => 'leaf', value_type => 'reference', refer_to => '- hash_a + ! hash_b', summary => 'justify a long help ;-) ', }, warn_unless => { type => 'leaf', value_type => 'string', warn_unless_match => { foo => { msg => '', fix => '$_ = "foo".$_;' } }, }, always_warn => { type => 'leaf', value_type => 'string', warn => 'Always warn whenever used', }, hash_with_warn_unless_key_match => { type => 'hash', index_type => 'string', cargo => { type => 'leaf', value_type => 'string' }, warn_unless_key_match => 'foo', }, ], description => [ tree_macro => 'controls behavior of other elements', a_long_string => "long string with \\n in it and with utf8 chars: ßéè", my_reference => "very long help:\n" . "Config::Model enables a project developer to provide an interactive configuration editor to his users. For this he must: - describe the structure and constraint of his project's configuration - if the configuration data is not stored in INI file or in Perl data file, he must provide some code to read and write configuration from configuration files. " ] ], ]; # do not put 1; at the end or Model-> load will not work Config-Model-TkUI-1.365/t/author-pod-syntax.t0000644000175000017500000000101613204357016017304 0ustar domidomi#!perl # # This file is part of Config-Model-TkUI # # This software is Copyright (c) 2008-2017 by Dominique Dumont. # # This is free software, licensed under: # # The GNU Lesser General Public License, Version 2.1, February 1999 # BEGIN { unless ($ENV{AUTHOR_TESTING}) { print qq{1..0 # SKIP these tests are for testing by the author\n}; exit } } # This file was automatically generated by Dist::Zilla::Plugin::PodSyntaxTests. use strict; use warnings; use Test::More; use Test::Pod 1.41; all_pod_files_ok(); Config-Model-TkUI-1.365/weaver.ini0000644000175000017500000000022513204357016015241 0ustar domidomi[@Default] [-Transformer] transformer = List [Support] perldoc = 0 bugs = metadata websites = search,anno,ratings,kwalitee,testers,testmatrix,deps Config-Model-TkUI-1.365/examples/0000755000175000017500000000000013204357016015066 5ustar domidomiConfig-Model-TkUI-1.365/examples/model.pl0000644000175000017500000000212313204357016016521 0ustar domidomi#!/usr/bin/perl # # This file is part of Config-Model-TkUI # # This software is Copyright (c) 2008-2017 by Dominique Dumont. # # This is free software, licensed under: # # The GNU Lesser General Public License, Version 2.1, February 1999 # # example contributed by # (c) 2009 Alexander Becker # Adapted to Unix and streamlined by # (c) 2009 Dominique Dumont # See https://rt.cpan.org/Ticket/Display.html?id=49999 use strict; use warnings; use Config::Model; use Config::Model::TkUI; use Log::Log4perl qw(:easy); # -- init trace Log::Log4perl->easy_init($WARN); # -- create configuration instance my $model = Config::Model->new(); # -- create config model $model->create_config_class( name => "SomeRootClass", element => [ country => { type => 'leaf', value_type => 'enum', choice => [qw/France US/] }, ], ); my $inst = $model->instance( root_class_name => 'SomeRootClass', ); my $root = $inst->config_root(); # -- Tk part my $mw = MainWindow->new(); $mw->withdraw(); $mw->ConfigModelUI(-root => $root); $mw->MainLoop(); Config-Model-TkUI-1.365/README0000644000175000017500000000676613204357016014147 0ustar domidomi Config::Model::TkUi - Tk GUI to edit config data through Config::Model This module provides a Perl/Tk interface to: - the configuration editor provided by Config::Model. - the configuration model editor provided by Config::Model::Itself For instance, with this module, Config::Model and Config::Model::OpenSsh, you get a graphical configuration editor for sshd_config. Copyright: - All *.png used in this application were created by Crystal Project. They are licensed under LGPL. http://www.everaldo.com/crystal/ (c) 2003-2007 Everaldo Coelho - tools_nicu_buculei_01.png from OpenCliparts is public domain. - dialog_warning.png from oxygen-icon-theme is GPL v3: Copyright (C) 2007-2009 David Vignoni Copyright (C) 2007-2009 Johann Ollivier Lapeyre Copyright (C) 2007-2009 Kenneth Wimer Copyright (C) 2007-2009 Nuno Fernades Pinheiro Copyright (C) 2007-2009 Riccardo Iaconelli Copyright (C) 2007-2009 David Miller and others. See /usr/share/doc/oxygen-icon-theme/copyright on a Debian machine - gnome-*.png from gnome-icon-theme are GPLv2: Copyright © 2002-2008: Ulisse Perusin Riccardo Buzzotta Josef Vybíral Hylke Bons Ricardo González Lapo Calamandrei Rodney Dawes Luca Ferretti Tuomas Kuosmanen Andreas Nilsson Jakub Steiner See /usr/share/doc/gnome-icon-theme/copyright on a Debian machine ----------------------------------------------------------- FEEDBACK and HELP wanted To fit user needs, this project needs feedback from its users. Please send your feedbacks, comments and ideas to : config-mode-users at lists.sourceforge.net This projects also needs help to improve its user interfaces: - Look and feel of Perl/Tk interface can be improved - A nice logo (a penguin with a wrench maybe ) would be welcomed - Config::Model could use a web interface - May be also an interface based on Gtk or Wx for better integration in Desktop If you want to help, please send a mail to: config-mode-devel at lists.sourceforge.net ----------------------------------------------------------- Legalese: Copyright (c) 2008-2010 Dominique Dumont. This file is part of Config-Model-TkUI. Config-Model is free software; you can redistribute it and/or modify it under the terms of the GNU Lesser Public License as published by the Free Software Foundation; either version 2.1 of the License, or (at your option) any later version. Config-Model is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Lesser Public License for more details. You should have received a copy of the GNU Lesser Public License along with Config-Model; if not, write to the Free Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA --------------------------------------------------------------------- INSTALLATION tar zxvf .tar.gz cd perl Build.PL ./Build ./Build test (optional) ./Build install (may need root capabilities) Config-Model-TkUI-1.365/Changes0000644000175000017500000004530313204357016014550 0ustar domidomi1.365 2017-11-19 * display node gist in tree widget (req Config::Model 2.114) * fix font issue when elements pop in node editor 1.364 2017-08-23 * fix font loading in TkUI (also gh #12) 1.363 2017-07-12 Improved functionality: * add Option->Font menu to choose cme tk font and size (gh #12) 1.362 2017-05-10 Bug fix: * bind mouse button 2 and 3 only on release (avoid double action on button press and then release) * fix undef warnings when pasting a value in tree before opening an editor or a viewer * Depends on Config::Model 2.095 (forgotten in v1.360) * add missing C-f C-c C-v bindings (other binding ideas are welcome, see gh #3) Improved functionality: * TkUI: open hash or array after pasting data Other: * change layout of test model file * dist.ini: update copyright years 1.361 2017-01-22 Bug fix: * TkUI: destroy parent only when parent isMainWindow (fix Config::Model::Itself itself-editor test) 1.360 2017-01-15 Bug fix: * handle correctly utf8 in pod text (Debian: #851178) * destroy main window when widget is closed (Debian: 850645) * NodeViewer: fix handling of elt containing a dot in their name 1.359 2016-11-28 Bug fix: * TkUI: fix display of leaf element (broke while fixing gh#7) 1.358 2016-11-27 Improved functionality: * show leaf value in a list when it contains *one* item (gh #7) * add "hide empty value" button (gh #9) * Indicate nb of elements in a list or hash (gh #8) * description widget is now expandable 1.357 2016-09-24 Bug fix: * fix crash after click on "apply fix" on a hash element 1.356 2016-05-29 Improved functionality: * "show only custom value" feature can now hide list and hash elements. This reduces clutter when viewing systemd config 1.355 2016-05-14 Improved functionality: * added Ctrl-q and Ctrl-s bindings (gh #3) Bug fixes: * update editor/viewer when pasting content. (gh #4) * fix show only custom value when opening a branch (gh #6) 1.354 2016-03-10 Fixed skipped test count to avoid smoke test failures on freebsd 1.353 2016-03-09 Bug fix: * Fixed broken display of string value when standard value is null (broken in 1.352) 1.352 2016-02-21 Improved diff functionality: * Show value diff only when standard value is not null * TkUI: show when a checklist is different from standard Bug fix: * Leaf editor: avoid error when using delete within wizard (gh #5) 1.351 2016-01-26 New functionality: * The leaf value viewer now show a diff of current value compared to standard value (only for value_type string). This will be useful with "cme edit dpkg-copyright) to check the difference of license text. This requires Text::Diff Important bug fix: * TkUI: Let reach the text editor (Closes github #2). This avoids loosing data: hitting return no longer closes the text editor. 1.350 2015-10-25 Improved usability: * Use double-click instead of rgith-click in tree to open item editor. Right-click is still working. * show note editor only when supported by backend (requires Config::Model >= 2.074) * improved balloon help message of list editor 1.349 2015-07-18 Bug fix release: * fixed quit to work even if no data was modified (regression in 1.348) * HashEditor: added 'clear' and 'copy' entry button. simplified 'keep' checkbutton behavior. * Reworked UI to avoid being messed up with multiline hash keys. This will improve the UI when editing debian/copyroght files (e.g. with "cme edit dpkg-copyright" done on nqp package) 1.348 2015-06-27 Important bug fix release: * Data was not saved when quitting with version 1.347. (e.g. menu: quit -> save changed data? -> yes -> oops, sorry, not done ) This is now fixed, data is saved *then* cme exits * fixed home page in dist.ini and META (Thanks Axel) 1.347 2015-06-14 Mostly a not so small bug fix release: * UI: * Increased font size used to render description of elements * Fix display of messages that were cancelled too fast * show "saving..." and "save done" message * LeafEditor: * fix regression where change done with external editor was not saved * Add .pod suffix to tmp file to let external editor use pod mode * meta info: * switch bug tracker to github * fixed repo url (Tx gregoa) 1.346 2015-05-09 Added new feature: * TkUI: add show_message method to display message at the bottom of the main widget for 5 seconds. 1.345 2015-01-10 Mostly a small bug fix release: * LeafEditor: * fix boolean value initialisation * improved error handling and report * updated © year 1.344 2014-05-20 * LeafEditor: use Path::Tiny instead of File::Slurp (RT #95691) * Removed 'experience' property from interface (which fixes the crash occuring with Config;:Model 2.056) 1.343 2014-05-04 * fixed number of tests issue detected by smoke tests 1.342 2014-05-02 * List editor: * sort button calls list->sort() (requires Config::Model 2.052) * replaced push button with insert at selection (for list of leaves) * added insort button (for list of leaves) * removed asynchronous code * removed dependency on AnyEvent 1.341 2014-03-02 * annotation editor: + add save/del button (requires Config::Model 2.050) * TkUI: * removed experimental given/when * also show items with warning or error when showing only customized items. 1.340 2013-08-29 This release fixes some long standing bug where warning and online help were not displayed in the GUI. In more details: * TkUi: reload tree when async store is finished * ListEditor: show warnings * LeafEditor: forgot to pack help frame * AnyViewer: lock pod help widget to 5 lines 1.339 2013-03-23 * LeafEditor: Th tree on the left side of the window is refreshed only once the async store is done. * requires Config::Model 2.030. * test: avoid AnyEvent and Tk lockup * build requires AnyEvent 1.338 2013-03-15 * LeafEditor: fixed external editor invocation to deal with utf-8 1.337 2012-05-29 * TkUI: * added 'show only custom values' check button in main panel * Bound 'Return' (aka Enter) key to begin search in the find widget (the one in 'Edit -> Find' menu) 1.336 2012-05-29 * replace deprecated get_all_indexes with fetch_all_indexes (requires Config::Model 2.017) * view_unsaved_change widget can now be expanded * fix dependency on Test::Memory::Cycle (with '::' between Memory and Cycle) 1.335 2012-05-06 * TkUI: enable quitting even if no data is to be saved * removed todo list. Added 'more info' help item * renamed show_changes menu into show_unsaved_changes 1.334 2012-05-05 * main widget (TkUI): + added show_change menu entry. Offer the same possibility when asked about saving before quitting * leaf editor: * Fix external editor call so the user can continue edition from widget to external editor without loosing modification already done in the text widget. + added ballon and changed button label to help user * require Config::Model 2.014 * build-depend on Test::MemoryCycle 1.333 2012-03-20 * Fix error when updating a leaf value through NodeEditor 1.332 2012-03-14 * Hash editor: enable buttons when mouse button-2 is released (paste) * wizard: clarify stop button. Added quit button * Leaf editor: grab focus when using external editor * Depends on Config::Model >= 2.001 1.331 2011-11-30 * dist.ini (hence Build.PL): Depends on Config::Model 1.263 (Fixes a bug triggered by new NodeEditor widget) 1.330 2011-11-29 * dist.ini (hence Build.PL): added Tk::Pod dependency (Fix RT# 72229) + NodeEditor: Added widget to add element when node has an accept clause * TkUI: trim also default value displayed in tk tree * ListEditor: do not update list widget when modif was refused by Config::Model 1.329 2011-10-10 * ListEditor: signal TKUI that data needs to be saved when list is modified * LeafEditor: do not clear entry when input is wrong. This is annoying * TkUI: updated license wording to keep Debian lintian happy 1.328 2011-09-23 * ListEditor: enable apply_fix button * TkUI: Restrict cut buffer paste to tree widget 1.327 2011-09-16 * TkUI.pm: * Fixed bug where force display did not work with hash keys containing non alphanumeric of space * Changed logger class to TkUI (instead of Config::Model::TkUI) 1.326 2011-09-02 * added check warning button in list viewer and editor 1.325 2011-05-17 * TkUI.pm: disable double-click because it trigger editor when double clicking outside of Hlist * NodeEditor.pm: respect order of element when completing the pane widget after warp 1.324 2011-05-17 * Depends on Config::Model 1.244 * TkUI: added search widget (menu "Edit -> Search" or just hit ) * ListEditor: fix bug that prevented to push a null value 1.323 2011-04-11 * LeafEditor: show value help widget only when useful * TkUI: added help menu entry to show the config class man page. * AnyViewer: use Tk::Text::Pod to display on-line help * Paste on List items will push content of cut buffer into the list * ListEditor: reworked layout for better usability, added sort button * HashEditor: reworked layout for better usability 1.322 2011-03-04 * Changed nb of skipped tests (fix test plan issues when Tk cannot be run) 1.321 2011-03-01 * TkUi.pm: renamed 'check' menu to 'check for errors'. Added 'check for warnings' * AnyViewer: renamed warning widget to 'issue'. Display errors with red background * NodeEditor: added widget to edit node annotations 1.320 2011-01-11 * LeafViewer: removed 'apply fix' button. This one is reserved for LeafEditor 1.319 2011-01-09 * LeafEditor: added fix button to fix warnings (if model provides a fix) * Wizard: clicking on next or previous does save value from wizard. 'stop' button will use new bail_out method from WizardHelper. 1.318 2010-12-21 * ListEditor: changed label of push button (minor) * Run-time depends on File::Slurp * LeafEditor: added external editor button 1.317 2010-11-05 * TkUi.pm: in Tk::Error call Show on Dialog to avoid masking errors 1.316 2010-10-19 * dist.ini/Buil.PL: added missing test dependency * LeadEditor: fix check call 1.315 2010-10-19 * Do no check value when creating widgets. Values will be checked when saving file * ListEditor: update 'set selected' entry when a list item is selected" 1.314 2010-10-15 * removed stuff obsoleted by Config::Model 1.212 * Depends on Config::Model 1.212 * added utf8 characters in tests 1.313 2010-10-08 * Added display of configuration warnings provided by Config::Model 1.211 * Depends on Config::Model >= 1.211 1.312 2010-10-04 * lib/Config/Model/TkUI.pm (disp_hash): Fixed the synchronize ordered hash display. It used to close displayed hash elements when modifying a value well below the hash :-( . 1.311 2010-09-10 * lib/Config/Model/Tk/HashEditor.pm (Populate): usability improvement: copy selected entry text into item when keep is set * lib/Config/Model/TkUI.pm (disp_hash): Synchronize ordered hash display in tree with respect to the hash editor 1.310 2010-09-10 * lib/Config/Model/Tk/HashEditor.pm (Populate): Fix bug that messed up effects of 'add' and 'move_down' buttons. 1.309 2010-08-08 * lib/Config/Model/Tk/AnyViewer.pm (add_help): Fix bug that hid summary and help text 1.308 2010-07-22 * MANIFEST.SKIP: added libconfig to avoid accidental upload of Debian test packages 1.307 2010-07-19 * lib/Config/Model/Tk/Wizard.pm (destroy_wizard): correctly destroy wizard widget when quitting. Also main window is hidden while wizard is running * lib/Config/Model/Tk/ListEditor.pm (move_down): fixed to move past element nb 2. * lib/Config/Model/Tk/HashEditor.pm (Populate): Following Krzystof's usability suggestion (http://tyszecki.org/), buttons are disabled when list selection or entry are empty. * Added annotations viewer and editor for Leaf, List, CheckList, Node, and Hash. This enable to view and edit comments in configuration files when the backend support reading and writing comments into Config::Model annotations 1.306 2010-03-29 * Build.PL: Depends on Config::Model 1.001 * lib/Config/Model/Tk/*.pm: Put back VERSION number and bumped them all to 1.305 to make CPAN indexer happy 1.305 2010-03-27 * Build.PL: depends on Pod::POM and on Config::Model >= 1.001 * lib/Config/Model/TkUI.pm (Populate): bound Ctrl-C and Ctrl-V to copy and paste in configuration tree widget. (Populate): use Pod::POM to display help from pod documentation * lib/Config/Model/Tk/Wizard.pm: Force tree to show item to edit when displaying the wizard page for the item. * lib/Config/Model/TkUI.pm (on_cut_buffer_dump): When button-2 is pressed above a lead, store cut buffer content in the leaf. When pressed above a hash, creates a new hash key for each line in the cut buffer. * lib/Config/Model/Tk/AnyViewer.pm (add_info_frame): display config parameter location in the tree on the top of all editor and viewer widgets. This will make the wizard easier to use. * lib/Config/Model/Tk/NodeEditor.pm (fill_pane): Stored entered data when widget looses keyboard focus 1.304 2010-03-12 * lib/Config/Model/TkUI.pm (disp_hash): Fix bug that messed tk tree content after deletion of list elements 1.303 2010-02-26 * Build.PL: Depends on Config::Model 0.643 * lib/Config/Model/Tk/HashViewer.pm (): Changed min and max calls to min_index and max_index * lib/Config/Model/Tk/AnyViewer.pm (add_help): added some padding aroung help text. Thanks to Eva Ganglbauer for the usability advice. (More advices are left to implement :-p ) 1.302 2010-01-21 * lib/Config/Model/Tk/NodeViewer.pm (reload): Correctly update value column when called * lib/Config/Model/Tk/HashEditor.pm (Populate): Mark data as modified when deleting all items of a hash. * examples/model.pl: Simple model and graphical interface example. Thanks to Alexander Becker. (RT 49999) * lib/Config/Model/Tk/LeafEditor.pm (try): Avoid warnings (RT 49999) * lib/Config/Model/TkUI.pm (save): trap write_back error. 1.301 2009-09-04 * lib/Config/Model/Tk/NodeEditor.pm: New widget to edit several config items in the same widget. * lib/Config/Model/Tk/NodeViewer.pm (Populate): Provide more details (type and if possible value) on node elements. * lib/Config/Model/TkUI.pm (Populate): Use 'beginner' as default experience level * lib/Config/Model/Tk/Wizard.pm: New file. Provides generic wizard for configuration edition. This wizard can be run at different experience (beginner, advanced or master). 1.211 2009-06-28 * lib/Config/Model/TkUI.pm (save): don't pass undefined dir parameter to avoid breaking write back function. (Fixes save problem Config::Mode::OpenSsh 1.206) 1.210 2009-06-23 * lib/Config/Model/Tk/LeafViewer.pm (add_info): use upstream_default() method instead of deprecated built_in(). * lib/Config/Model/TkUI.pm (Populate): added -title option so the application can set the title of the TkUI window 1.208 2009-04-07 * lib/Config/Model/Tk/HashEditor.pm (Populate): Improved widget ergonomy. Added some balloon help. * lib/Config/Model/Tk/*.pm (): Added display of summary 1.207 2009-03-12 * lib/Config/Model/Tk/LeafEditor.pm (cleanup): new method (and Text editor button) to normalize white space in a string. Useful when filling configuration parameter description from a man page with cut'n'paste. 1.204 2008-12-22 * *.pm: replaced Tango icons with Crystal icons (LGPL) to comply with Debian DFSG. * lib/Config/Model/Tk/HashEditor.pm (add_entry): Fixed bug that prevented to insert a new item in the middle of an ordered hash * lib/Config/Model/Tk/ListEditor.pm (remove_selection): fixed bug that displayed wrong indexes when deleting an element of a list of nodes. 1.203 2008-10-13 * lib/Config/Model/Tk/CheckListEditor.pm: added Notebook tab to provide 2 ways to edit an ordered checklist: change the content (check or uncheck items) or change the order of the items. This feature is necessary to correctly edit the Ciphers list of ssh_config model (See Config::Model::OpenSsh) * Build.PL: Extract version from Config/Model/TkUI.pm (hence the bump to v 1.203) so that the pm file versions matches the .tgz distribution version. * lib/Config/Model/Tk/ListEditor.pm (Populate): Better handles list of enum values * lib/Config/Model/TkUI.pm (edit_paste): Cut'n'paste improvements for list elements * lib/Config/Model/Tk/ListEditor.pm (swap): No more hiccups when moving list items past boundaries. Indexes are no longer moved in the rightmost box when moving node items in a list. It was confusing to have array indexes in the wrong order. 0.202 2008-07-25 * lib/Config/Model/Tk/ListEditor.pm (Populate): can now move up and down node list items. This is handy when order of nodes is important. 0.201 2008-06-18 * lib/Config/Model/TkUI.pm (Populate): Replaced "placeholder" with logo (edit_copy): Bug fix that prevented copying hash elements. 0.105 2008-05-07 * lib/Config/Model/TkUI.pm (): Added Edit menu with copy and paste entries. (No, there won't be a 'cut' entry). * lib/Config/Model/Tk/LeafEditor.pm: Fix bug in value help display * lib/Config/Model/Tk/HashEditor.pm (move_selected_to): Fixed move within ordered hash * lib/Config/Model/Tk/ListEditor.pm (set_all_items): new method to set a list with a list of words. They can be separated by commas, white spaces or any non-alphanumeric character (e.g. /\W+/) * lib/Config/Model/Tk/HashEditor.pm: Select and show new items in Listbox * lib/Config/Model/TkUI.pm: Add debug menu (rely on Tk::ObjScanner). Bug fix related to configuration check * TkUI CheckListEditor and Viewer: Reworked for better edition 0.104 2008-04-03 * lib/Config/Model/TkUI.pm: added File->check menu entry * lib/Config/Model/Tk/HashEditor.pm ():added up and down buttons for ordered hashes * lib/Config/Model/NodeViewer.pm: Fix bug that prevented view of root configuration class * lib/Config/Model/Tk/ListEditor.pm: Reworked to provide better list editor. Hash and List editor are now handled by separate widgets. * lib/Config/Model/TkUI.pm (disp_leaf): cut long string in HList display (on the left) 0.103 2008-03-12 * t/config-model-ui.t (inc_d): Fixed test to load TkUI instead of TkUi 0.102 2008-03-07 * Renamed TkUi.pm to TkUI.pm to fit Module list declaration * TkUI.pm (Populate): added -store_sub option * all: Moved to svn * all: Changed keywords substitution to fit svn Config-Model-TkUI-1.365/lib/0000755000175000017500000000000013204357016014016 5ustar domidomiConfig-Model-TkUI-1.365/lib/Config/0000755000175000017500000000000013204357016015223 5ustar domidomiConfig-Model-TkUI-1.365/lib/Config/Model/0000755000175000017500000000000013204357016016263 5ustar domidomiConfig-Model-TkUI-1.365/lib/Config/Model/TkUI.pm0000644000175000017500000013264313204357016017446 0ustar domidomi# # This file is part of Config-Model-TkUI # # This software is Copyright (c) 2008-2017 by Dominique Dumont. # # This is free software, licensed under: # # The GNU Lesser General Public License, Version 2.1, February 1999 # # copyright at the end of the file in the pod section package Config::Model::TkUI; $Config::Model::TkUI::VERSION = '1.365'; use 5.10.1; use strict; use warnings; use Carp; use base qw/Tk::Toplevel/; use vars qw/$icon_path $error_img $warn_img/; use subs qw/menu_struct/; use Scalar::Util qw/weaken/; use Log::Log4perl 1.11; use Path::Tiny; use YAML qw/LoadFile DumpFile/; use File::HomeDir; use Pod::POM; use Pod::POM::View::Text; use Tk::DoubleClick; use Tk::Photo; use Tk::PNG; # required for Tk::Photo to be able to load pngs use Tk::DialogBox; use Tk::Adjuster; use Tk::FontDialog; use Tk::Pod; use Tk::Pod::Text; # for findpod use Config::Model 2.114; # Node::gist use Config::Model::Tk::LeafEditor; use Config::Model::Tk::CheckListEditor; use Config::Model::Tk::LeafViewer; use Config::Model::Tk::CheckListViewer; use Config::Model::Tk::ListViewer; use Config::Model::Tk::ListEditor; use Config::Model::Tk::HashViewer; use Config::Model::Tk::HashEditor; use Config::Model::Tk::NodeViewer; use Config::Model::Tk::NodeEditor; use Config::Model::Tk::Wizard; Construct Tk::Widget 'ConfigModelUI'; my $cust_img; my $tool_img; my %gnome_img; my $mod_file = 'Config/Model/TkUI.pm'; $icon_path = $INC{$mod_file}; $icon_path =~ s/TkUI.pm//; $icon_path .= 'Tk/icons/'; my $logger = Log::Log4perl::get_logger('TkUI'); no warnings "redefine"; sub Tk::Error { my ( $cw, $error, @locations ) = @_; my $msg = ( ref($error) && $error->can('as_string') ) ? $error->as_string : $error; warn $msg; $msg .= "Tk stack: \n@locations\n"; $cw->Dialog( -title => 'Config::Model error', -text => $msg, )->Show; } use warnings "redefine"; my $default_config = { font => { -family => 'DejaVu Sans', qw/-size -13 -weight normal/ } }; my $main_window; my $config_path = path(File::HomeDir->my_home)->child('.cme/config/'); my $config_file = $config_path->child('tkui.yml'); $config_path -> mkpath; my $config = $config_file->is_file ? LoadFile($config_file) : $default_config ; # Tk::CmdLine::SetArguments( -font => $config->{font} ) ; sub ClassInit { my ( $class, $mw ) = @_; $main_window = $mw; # ClassInit is often used to define bindings and/or other # resources shared by all instances, e.g., images. # cw->Advertise(name=>$widget); } sub set_font { my $cw = shift; my $tk_font = $main_window->FontDialog->Show; if (defined $tk_font) { $main_window->RefontTree(-font => $tk_font); $config->{font} = {$tk_font->actual} ; $cw->ConfigSpecs( -font => ['DESCENDANTS', 'font','Font', $tk_font ]); DumpFile($config_file->stringify, $config); } } sub Populate { my ( $cw, $args ) = @_; unless ( defined $error_img ) { $error_img = $cw->Photo( -file => $icon_path . 'stop.png' ); $cust_img = $cw->Photo( -file => $icon_path . 'next.png' ); # snatched from oxygen-icon-theme $warn_img = $cw->Photo( -file => $icon_path . 'dialog-warning.png' ); # snatched from openclipart-png $tool_img = $cw->Photo( -file => $icon_path . 'tools_nicu_buculei_01.png' ); $gnome_img{next} = $cw->Photo( -file => $icon_path . 'gnome-next.png' ); $gnome_img{previous} = $cw->Photo( -file => $icon_path . 'gnome-previous.png' ); } foreach my $parm (qw/-root/) { my $attr = $parm; $attr =~ s/^-//; $cw->{$attr} = delete $args->{$parm} or croak "Missing $parm arg\n"; } foreach my $parm (qw/-store_sub -quit/) { my $attr = $parm; $attr =~ s/^-//; $cw->{$attr} = delete $args->{$parm}; } my $extra_menu = delete $args->{'-extra-menu'} || []; my $title = delete $args->{'-title'} || $0 . " " . $cw->{root}->config_class_name; # check unknown parameters croak "Unknown parameter ", join( ' ', keys %$args ) if %$args; # initialize internal attributes $cw->{location} = ''; $cw->{current_mode} = 'view'; $cw->setup_scanner(); # create top menu require Tk::Menubutton; my $menubar = $cw->Menu; $cw->configure( -menu => $menubar ); $cw->{my_menu} = $menubar; my $file_items = [ [ qw/command wizard -command/, sub { $cw->wizard } ], [ qw/command reload -command/, sub { $cw->reload } ], [ command => 'check for errors', -command => sub { $cw->check(1) } ], [ command => 'check for warnings', -command => sub { $cw->check( 1, 1 ) } ], [ command => 'show unsaved changes', -command => sub { $cw->show_changes; } ], [ command => 'save (Ctrl-s)', -command => sub { $cw->save } ], [ command => 'save in dir ...', -command => sub { $cw->save_in_dir; } ], @$extra_menu, [ command => 'debug ...', -command => sub { require Tk::ObjScanner; Tk::ObjScanner::scan_object( $cw->{root} ); } ], [ command => 'quit (Ctrl-q)', -command => sub { $cw->quit } ], ]; $menubar->cascade( -label => 'File', -menuitems => $file_items ); $cw->add_help_menu($menubar); $cw->bind( '', sub { $cw->save } ); $cw->bind( '', sub { $cw->quit } ); $cw->bind( '', sub { $cw->edit_copy } ); $cw->bind( '', sub { $cw->edit_paste } ); $cw->bind( '', sub { $cw->pack_find_widget } ); my $edit_items = [ # [ qw/command cut -command/, sub{ $cw->edit_cut }], [ command => 'copy (Ctrl-c)', '-command', sub { $cw->edit_copy } ], [ command => 'paste (Ctrl-v)', '-command', sub { $cw->edit_paste } ], [ command => 'find (Ctrl-f)', '-command', sub { $cw->pack_find_widget; } ], ]; $menubar->cascade( -label => 'Edit', -menuitems => $edit_items ); my $option_items = [ [ command => 'Font', '-command', sub { $cw->set_font(); } ], ]; $menubar->cascade( -label => 'Options', -menuitems => $option_items ); # create frame for location entry my $loc_frame = $cw->Frame( -relief => 'sunken', -borderwidth => 1 )->pack( -pady => 0, -fill => 'x' ); $loc_frame->Label( -text => 'location :' )->pack( -side => 'left' ); $loc_frame->Label( -textvariable => \$cw->{location} )->pack( -side => 'left' ); # create 'show only custom values' $cw->{show_only_custom} = 0; $loc_frame->Checkbutton( -variable => \$cw->{show_only_custom}, -command => sub { $cw->reload }, )->pack( -side => 'right' ); $loc_frame->Label( -text => 'show only custom values' )->pack( -side => 'right' ); # create 'hide empty values' $cw->{hide_empty_values} = 0; $loc_frame->Checkbutton( -variable => \$cw->{hide_empty_values}, -command => sub { $cw->reload }, )->pack( -side => 'right' ); $loc_frame->Label( -text => 'hide empty values' )->pack( -side => 'right' ); # add bottom frame my $bottom_frame = $cw->Frame->pack(qw/-pady 0 -fill both -expand 1/); # create the widget for tree navigation require Tk::Tree; my $tree = $bottom_frame->Scrolled( qw/Tree/, -columns => 4, -header => 1, -opencmd => sub { $cw->open_item(@_); }, -closecmd => sub { $cw->close_item(@_); }, )->pack(qw/-fill both -expand 1 -side left/); $cw->{tktree} = $tree; # add adjuster $bottom_frame->Adjuster()->packAfter( $tree, -side => 'left' ); # add headers $tree->headerCreate( 0, -text => "element" ); $tree->headerCreate( 1, -text => "status" ); $tree->headerCreate( 2, -text => "value" ); $tree->headerCreate( 3, -text => "standard value" ); $cw->reload; # add frame on the right for entry and help my $eh_frame = $bottom_frame->Frame->pack(qw/-fill both -expand 1 -side right/); # add entry frame, filled by call-back # should be a composite widget my $e_frame = $eh_frame->Frame->pack(qw/-side top -fill both -expand 1/); $e_frame->Label( #-text => "placeholder", -image => $tool_img, -width => 400, # width in pixel for image )->pack( -side => 'top' ); $e_frame->Button( -text => "Run Wizard !", -command => sub { $cw->wizard } )->pack( -side => 'bottom' ); my $b1_sub = sub { my $item = $tree->nearest( $tree->pointery - $tree->rooty ); $cw->on_browse($item); }; my $b3_sub = sub { my $item = $tree->nearest( $tree->pointery - $tree->rooty ); $cw->on_select($item); }; $tree->bind( '', $b3_sub ); $tree->bind( '', $b3_sub ); bind_clicks($tree,$b1_sub, $b3_sub); # bind button2 to get cut buffer content and try to store cut buffer content my $b2_sub = sub { my $item = $tree->nearest( $tree->pointery - $tree->rooty ); $cw->on_cut_buffer_dump($item); }; $tree->bind( '', $b2_sub ); $tree->bind( '', sub { $cw->edit_copy } ); $tree->bind( '', sub { $cw->edit_paste } ); $tree->bind( '', sub { $cw->pack_find_widget } ); my $find_frame = $cw->create_find_widget; # create frame for message my $msg_label = $cw->Label( -textvariable => \$cw->{message}, -relief => 'sunken', -borderwidth => 1, -anchor =>'w', ); $msg_label->pack( -pady => 0, -fill => 'x' ); $args->{-title} = $title; $cw->SUPER::Populate($args); my $tk_font = $cw->Font(%{$config->{font}}); $cw->ConfigSpecs( -font => ['DESCENDANTS', 'font','Font', $tk_font ], #-background => ['DESCENDANTS', 'background', 'Background', $background], #-selectbackground => [$hlist, 'selectBackground', 'SelectBackground', # $selectbackground], -tree_width => [ 'METHOD', undef, undef, 80 ], -tree_height => [ 'METHOD', undef, undef, 30 ], -width => [ $eh_frame, qw/width Width 1280/ ], -height => [ $eh_frame, qw/height Height 1024/ ], -selectmode => [ $tree, 'selectMode', 'SelectMode', 'single' ], #single', #-oldcursor => [$hlist, undef, undef, undef], DEFAULT => [$tree] ); $cw->Advertise( tree => $tree ); $cw->Advertise( menubar => $menubar ); $cw->Advertise( right_frame => $eh_frame ); $cw->Advertise( ed_frame => $e_frame ); $cw->Advertise( find_frame => $find_frame ); $cw->Advertise( msg_label => $msg_label ); $cw->OnDestroy(sub {$cw->Parent->destroy if ref($cw->Parent) eq 'MainWindow'} ); $cw->Delegates; } sub show_message { my ( $cw, $msg ) = @_; # $cw->Subwidget('msg_label')->configure(-background => "red"); # does not work $cw->{message} = $msg; if (my $id = $cw->{id}) { $cw->afterCancel($id) ; } ; my $unshow = sub { delete $cw->{id}; $cw->{message} = ''; } ; $cw->{id} = $cw->after(5000,$unshow) ; } sub tree_width { my ( $cw, $value ) = @_; $cw->Subwidget('tree')->configure( -width => $value ); } sub tree_height { my ( $cw, $value ) = @_; $cw->Subwidget('tree')->configure( -height => $value ); } my $parser = Pod::POM->new(); # parse from my documentation my $pom = $parser->parse_file(__FILE__) || die $parser->error(); my $help_text; my $todo_text; my $info_text; foreach my $head1 ( $pom->head1() ) { $help_text = Pod::POM::View::Text->view_head1($head1) if $head1->title eq 'USAGE'; $info_text = Pod::POM::View::Text->view_head1($head1) if $head1->title =~ /more information/i; } sub add_help_menu { my ( $cw, $menubar ) = @_; my $about_sub = sub { $cw->Dialog( -title => 'About', -text => "Config::Model::TkUI \n" . "(c) 2008-2012 Dominique Dumont \n" . "Licensed under LGPLv2\n" )->Show; }; my $info_sub = sub { my $db = $cw->DialogBox( -title => 'TODO' ); my $text = $db->add( 'Scrolled', 'ROText' )->pack; $text->insert( 'end', $info_text ); $db->Show; }; my $help_sub = sub { my $db = $cw->DialogBox( -title => 'help' ); my $text = $db->add( 'Scrolled', 'ROText' )->pack; $text->insert( 'end', $help_text ); $db->Show; }; my $class = $cw->{root}->config_class_name; my $man_sub = sub { $cw->Pod( -tree => 0, -file => "Config::Model::models::" . $class, -title => $class, -exitbutton => 0, ); }; my $help_items = [ [ qw/command About -command/, $about_sub ], [ qw/command Usage -command/, $help_sub ], [ command => 'More info', -command => $info_sub ], [ command => "$class help", -command => $man_sub ], ]; $menubar->cascade( -label => 'Help', -menuitems => $help_items ); } # Note: this callback is called by Tk::Tree *before* changing the # indicator. And the indicator is used by Tk::Tree to store the # open/close/none mode. So we can't rely on getmode for path that are # opening. Hence the parameter passed to the sub stored with each # Tk::Tree item sub open_item { my ( $cw, $path ) = @_; my $tktree = $cw->{tktree}; $logger->trace("open_item on $path"); my $data = $tktree->infoData($path); # invoke the scanner part (to create children) # the parameter indicates that we are opening this path $data->[0]->(1); $cw->show_single_list_value ($tktree, $data->[1], $path, 0); my @children = $tktree->infoChildren($path); $logger->trace("open_item show @children"); map { $tktree->show( -entry => $_ ); } @children; } sub close_item { my ( $cw, $path ) = @_; my $tktree = $cw->{tktree}; $logger->trace("close_item on $path"); my $data = $tktree->infoData($path); $cw->show_single_list_value ($tktree, $data->[1], $path, 1); my @children = $tktree->infoChildren($path); $logger->trace("close_item hide @children"); map { $tktree->hide( -entry => $_ ); } @children; } sub save_in_dir { my $cw = shift; require Tk::DirSelect; $cw->{save_dir} = $cw->DirSelect()->Show; # chooseDirectory does not work correctly. #$cw->{save_dir} = $cw->chooseDirectory(-mustexist => 'no') ; $cw->save(); } sub check { my $cw = shift; my $show = shift || 0; my $check_warnings = shift || 0; my $wiz = $cw->setup_wizard( sub { $cw->check_end( $show, @_ ); } ); $wiz->start_wizard( stop_on_warning => $check_warnings ); } sub check_end { my $cw = shift; my $show = shift; my $has_stopped = shift; $cw->reload if $has_stopped; if ( $show and not $has_stopped ) { $cw->Dialog( -title => 'Check', -text => "No issue found" )->Show; } } sub save { my $cw = shift; my $cb = shift || sub {}; my $dir = $cw->{save_dir}; my $trace_dir = defined $dir ? $dir : 'default'; my @wb_args = defined $dir ? ( config_dir => $dir ) : (); my $save_job = sub { $cw->check(); # may be long if ( defined $cw->{store_sub} ) { $logger->info("Saving data in $trace_dir directory with store call-back"); eval { $cw->{store_sub}->($dir) }; } else { $logger->info("Saving data in $trace_dir directory with instance write_back"); eval { $cw->{root}->instance->write_back(@wb_args); }; } if ($@) { $cw->Dialog( -title => 'Save error', -text => ref($@) ? $@->as_string : $@, )->Show; $cb->($@); # indicate failure } else { $cw->show_message("Save done ..."); $cb->(); } }; $cw->show_message("Saving... please wait ..."); # use a short delay to let tk show the message above and then save $cw->after(100, $save_job) ; } sub quit { my $cw = shift; my $text = shift || "Save data ?"; if ( $cw->{root}->instance->needs_save ) { my $answer = $cw->Dialog( -title => "quit", -text => $text, -buttons => [ qw/yes no cancel/, 'show changes' ], -default_button => 'yes', )->Show; if ( $answer eq 'yes' ) { $cw->save( sub {$cw->self_destroy;}); } elsif ( $answer eq 'no' ) { $cw->self_destroy; } elsif ( $answer =~ /show/ ) { $cw->show_changes( sub { $cw->quit } ); } } else { $cw->self_destroy; } } sub self_destroy { my $cw = shift; if ( defined $cw->{quit} and $cw->{quit} eq 'soft' ) { $cw->destroy; } else { # destroy main window to exit Tk Mainloop; $cw->parent->destroy; } } sub show_changes { my $cw = shift; my $cb = shift; my $changes = $cw->{root}->instance->list_changes; my $change_widget = $cw->Toplevel; $change_widget->Scrolled('ROText')->pack( -expand => 1, -fill => 'both' ) ->insert( '1.0', $changes ); $change_widget->Button( -command => sub { $change_widget->destroy; $cb->() if defined $cb; }, -text => 'ok', )->pack; } sub reload { my $cw = shift; carp "reload: too many parameters" if @_ > 1; my $force_display_path = shift; # force open editor on this path $logger->trace( "reloading tk tree" . ( defined $force_display_path ? " (force display $force_display_path)" : '' ) ); my $tree = $cw->{tktree}; my $instance_name = $cw->{root}->instance->name; my $new_drawing = not $tree->infoExists($instance_name); my $sub = sub { $cw->{scanner}->scan_node( [ $instance_name, $cw, @_ ], $cw->{root} ); }; if ($new_drawing) { $tree->add( $instance_name, -data => [ $sub, $cw->{root} ] ); $tree->itemCreate( $instance_name, 0, -text => $instance_name, ); $tree->setmode( $instance_name, 'close' ); $tree->open($instance_name); } # the first parameter indicates that we are opening the root $sub->( 1, $force_display_path ); $tree->see($force_display_path) if ( $force_display_path and $tree->info( exists => $force_display_path ) ); $cw->{editor}->reload if defined $cw->{editor}; } # call-back when Tree element is selected sub on_browse { my ( $cw, $path ) = @_; $cw->update_loc_bar($path); $cw->create_element_widget('view'); } sub update_loc_bar { my ( $cw, $path ) = @_; #$cw->{path}=$path ; my $datar = $cw->{tktree}->infoData($path); my $obj = $datar->[1]; $cw->{location} = $obj->location_short; } sub on_select { my ( $cw, $path ) = @_; $cw->update_loc_bar($path); $cw->create_element_widget('edit'); } sub on_cut_buffer_dump { my ( $cw, $tree_path ) = @_; $cw->update_loc_bar($tree_path); # get cut buffer content, See Perl/Tk book p297 my $sel = eval { $cw->SelectionGet; }; return if $@; # no selection my $obj = $cw->{tktree}->infoData($tree_path)->[1]; if ( $obj->isa('Config::Model::Value') ) { # if leaf store content $obj->store( value => $sel, callback => sub { $cw->reload; } ); } elsif ( $obj->isa('Config::Model::HashId') ) { # if hash create keys my @keys = ( $sel =~ /\n/m ) ? split( /\n/, $sel ) : ($sel); map { $obj->fetch_with_id($_) } @keys; } elsif ( $obj->isa('Config::Model::ListId') and $obj->get_cargo_type !~ /node/ ) { # if array, push values my @v = ( $sel =~ /\n/m ) ? split( /\n/, $sel ) : ( $sel =~ /,/ ) ? split( /,/, $sel ) : ($sel); $obj->push(@v); } # else ignore # display result $cw->reload; $cw->create_element_widget($cw->{current_mode}, $tree_path); $cw->open_item($tree_path); } # replace dot in str by _|_ sub to_path { my $str = shift; $str =~ s/\./_|_/g; return $str; } sub force_element_display { my $cw = shift; my $elt_obj = shift; $logger->trace( "force display of " . $elt_obj->location ); $cw->reload( $elt_obj->location ); } sub prune { my $cw = shift; my $path = shift; $logger->trace("prune $path"); my %list = map { "$path." . to_path($_) => 1 } @_; # remove entries that are not part of the list my $tkt = $cw->{tktree}; map { $tkt->deleteEntry($_) if $_ and not defined $list{$_}; } $tkt->infoChildren($path); $logger->trace("prune $path done"); } # Beware: TkTree items store tree object and not tree cds path. These # object might become irrelevant when warp master values are # modified. So the whole Tk Tree layout must be redone very time a # config value is modified. This is a bit heavy, but a smarter # alternative would need hooks in the configuration tree to # synchronise the Tk Tree with the configuration tree :-p my %elt_mode = ( leaf => 'none', hash => 'open', list => 'open', node => 'open', check_list => 'none', warped_node => 'open', ); sub disp_obj_elt { my ( $scanner, $data_ref, $node, @element_list ) = @_; my ( $path, $cw, $opening, $fd_path ) = @$data_ref; my $tkt = $cw->{tktree}; my $mode = $tkt->getmode($path); if ($cw->{show_only_custom} or $cw->{hide_empty_values}) { my @new_element_list; foreach my $elt ( @element_list ) { my $obj = $node->fetch_element($elt); if ($cw->{show_only_custom}) { push @new_element_list, $elt if $node->fetch_element($elt)->has_data; } elsif ($cw->{hide_empty_values}) { my $elt_type = $obj->get_type; my $show = $elt_type eq 'hash' ? $obj->has_data : $elt_type eq 'list' ? $obj->has_data : $elt_type eq 'leaf' ? length($obj->fetch(qw/mode user check no/) // '') : $elt_type eq 'check_list' ? $obj->fetch(mode => 'user') : 1 ; push @new_element_list, $elt if $show; } } @element_list = @new_element_list; } $logger->trace( "disp_obj_elt path $path mode $mode opening $opening " . "(@element_list)" ); $cw->prune( $path, @element_list ); my $node_loc = $node->location; my $prevpath = ''; foreach my $elt (@element_list) { my $newpath = "$path." . to_path($elt); my $scan_sub = sub { $scanner->scan_element( [ $newpath, $cw, @_ ], $node, $elt ); }; my @data = ( $scan_sub, $node->fetch_element($elt) ); # It's necessary to store a weakened reference of a tree # object as these ones tend to disappear when warped out. In # this case, the object must be destroyed. This does not # happen if a non-weakened reference is kept in Tk Tree. weaken( $data[1] ); my $elt_type = $node->element_type($elt); my $eltmode = $elt_mode{$elt_type}; if ( $tkt->infoExists($newpath) ) { $eltmode = $tkt->getmode($newpath); # will reuse mode below } else { my @opt = $prevpath ? ( -after => $prevpath ) : ( -at => 0 ); $logger->trace("disp_obj_elt add $newpath mode $eltmode type $elt_type"); $tkt->add( $newpath, -data => \@data, @opt ); $tkt->itemCreate( $newpath, 0, -text => $elt ); $tkt->setmode( $newpath => $eltmode ); } my $elt_loc = $node_loc ? $node_loc . ' ' . $elt : $elt; $cw->setmode( 'node', $newpath, $eltmode, $elt_loc, $fd_path, $opening, $scan_sub ); my $obj = $node->fetch_element($elt); if ( $elt_type eq 'hash' ) { $cw->update_hash_image( $obj, $newpath ); } if ($elt_type eq 'hash' or $elt_type eq 'list') { my $size = $obj->fetch_size; $tkt->entryconfigure($newpath, -text => "$elt [$size]"); } $cw->show_single_list_value ($tkt, $obj, $newpath, $tkt->getmode($newpath) eq 'open' ? 1 : 0); $prevpath = $newpath; } } # show a list like a leaf value when the list contains *one* item sub show_single_list_value { my ($cw, $tkt, $obj, $path, $show) = @_; my $elt_type = $obj->get_type; # leave alone element that is not a list of leaf return unless $elt_type eq 'list' and $obj->get_cargo_type eq 'leaf'; $logger->trace("show_single_list_value called on ", $obj->location); if ($obj->fetch_size == 1 and $show) { disp_leaf(undef,[ $path, $cw ], $obj->parent, $obj->element_name, 0, $obj->fetch_with_id(0)); } else { map {$tkt->itemDelete( $path, $_ ) if $tkt->itemExists($path, $_);} qw/1 2 3/; } } sub disp_hash { my ( $scanner, $data_ref, $node, $element_name, @idx ) = @_; my ( $path, $cw, $opening, $fd_path ) = @$data_ref; my $tkt = $cw->{tktree}; my $mode = $tkt->getmode($path); $logger->trace("disp_hash path is $path mode $mode (@idx)"); $cw->prune( $path, @idx ); my $elt = $node->fetch_element($element_name); my $elt_type = $elt->get_cargo_type(); my $node_loc = $node->location; # need to keep track myself of previous sibling as # $tkt->entrycget($path,'-after') dies # and $tkt->info('prev',$path) return the path above in the displayed tree, which # is not necessarily a sibling :-( my $prev_sibling = ''; my %tk_previous_path; foreach ( $tkt->info( 'children', $path ) ) { $tk_previous_path{$_} = $prev_sibling; $prev_sibling = $_; } my $prevpath = ''; foreach my $idx (@idx) { my $newpath = $path . '.' . to_path($idx); my $scan_sub = sub { $scanner->scan_hash( [ $newpath, $cw, @_ ], $node, $element_name, $idx ); }; my $eltmode = $elt_mode{$elt_type}; my $sub_elt = $elt->fetch_with_id($idx); # check for display order mismatch if ( $tkt->infoExists($newpath) ) { if ( $prevpath ne $tk_previous_path{$newpath} ) { $logger->trace( "disp_hash deleting mismatching $newpath mode $eltmode cargo_type $elt_type"); $tkt->delete( entry => $newpath ); } } # check for content mismatch if ( $tkt->infoExists($newpath) ) { my $previous_data = $tkt->info( data => $newpath ); # $previous_data is an object (or an empty string to avoid warnings) my $previous_elt = $previous_data->[1] || ''; $eltmode = $tkt->getmode($newpath); # will reuse mode below $logger->trace( "disp_hash reuse $newpath mode $eltmode cargo_type $elt_type" . " obj $previous_elt (expect $sub_elt)" ); # string comparison of objects is intentional to check that the tree # refers to the correct Config::Model object if ( $sub_elt ne $previous_elt ) { $logger->trace( "disp_hash delete $newpath mode $eltmode (got " . "$previous_elt expected $sub_elt)" ); # wrong order, delete the entry $tkt->delete( entry => $newpath ); } } if ( not $tkt->infoExists($newpath) ) { my @opt = $prevpath ? ( -after => $prevpath ) : ( -at => 0 ); $logger->trace( "disp_hash add $newpath mode $eltmode cargo_type $elt_type" . " elt $sub_elt" ); my @data = ( $scan_sub, $sub_elt ); weaken( $data[1] ); $tkt->add( $newpath, -data => \@data, @opt ); $tkt->itemCreate( $newpath, 0, -text => $node->shorten_idx($idx) ); $tkt->setmode( $newpath => $eltmode ); } # update the node gist my $gist = $elt_type =~ /node/ ? $elt->fetch_with_id($idx)->fetch_gist : ''; $tkt->itemCreate( $newpath, 2, -text => $gist ); my $elt_loc = $node_loc; $elt_loc .= ' ' if $elt_loc; # need to keep regexp identical to the one from C::M::Anything:composite_name # so that force_display_path (aka fd_path may work) $elt_loc .= $element_name . ':' . ( $idx =~ /\W/ ? '"' . $idx . '"' : $idx ); # hide new entry if hash is not yet opened $cw->setmode( 'hash', $newpath, $eltmode, $elt_loc, $fd_path, $opening, $scan_sub ); $prevpath = $newpath; } } sub update_hash_image { my ( $cw, $elt, $path ) = @_; my $tkt = $cw->{tktree}; # check hash status and set warning image if necessary my $img; { no warnings qw/uninitialized/; $img = $warn_img if $elt->warning_msg; } if ( defined $img ) { $tkt->itemCreate( $path, 1, -itemtype => 'image', -image => $img ); } else { $tkt->itemDelete( $path, 1 ) if $tkt->itemExists( $path, 1 ); } } sub setmode { my ( $cw, $type, $newpath, $eltmode, $elt_loc, $fd_path, $opening, $scan_sub ) = @_; my $tkt = $cw->{tktree}; my $force_open = ( $fd_path and index( $fd_path, $elt_loc ) == 0 ) ? 1 : 0; my $force_match = ( $fd_path and $fd_path eq $elt_loc ) ? 1 : 0; $logger->trace( "$type: elt_loc '$elt_loc', opening $opening " . "eltmode $eltmode force_open $force_open " . ( $fd_path ? "on '$fd_path' " : '' ) . "force_match $force_match" ); if ( $eltmode ne 'open' or $force_open or $opening ) { $tkt->show( -entry => $newpath ); # counter-intuitive: want to display [-] if force opening and not leaf item $tkt->setmode( $newpath => 'close' ) if ( $force_open and $eltmode ne 'none' ); } else { $tkt->close($newpath); } # counterintuitive but right: scan will be done when the entry # is opened. mode can be open, close, none $scan_sub->( $force_open, $fd_path ) if ( ( $eltmode ne 'open' ) or $force_open ); if ($force_match) { $tkt->see($newpath); $tkt->selectionSet($newpath); $cw->update_loc_bar($newpath); $cw->create_element_widget( 'edit', $newpath ); } } sub trim_value { my $cw = shift; my $value = shift; return undef unless defined $value; $value =~ s/\n/ /g; $value = substr( $value, 0, 15 ) . '...' if length($value) > 15; return $value; } sub disp_check_list { my ( $scanner, $data_ref, $node, $element_name, $index, $leaf_object ) = @_; my ( $path, $cw, $opening, $fd_path ) = @$data_ref; $logger->trace("disp_check_list path is $path"); my $value = $leaf_object->fetch; my $tkt = $cw->{tktree}; $tkt->itemCreate( $path, 2, -text => $cw->trim_value($value) ); my $std_v = $leaf_object->fetch('standard'); $tkt->itemCreate( $path, 3, -text => $cw->trim_value($std_v) ); if ( $std_v ne $value ) { $tkt->itemCreate( $path, 1, -itemtype => 'image', -image => $cust_img ); } else { # remove image when value is identical to standard value $tkt->itemDelete( $path, 1 ) if $tkt->itemExists( $path, 1 ); } } sub disp_leaf { my ( $scanner, $data_ref, $node, $element_name, $index, $leaf_object ) = @_; my ( $path, $cw, $opening, $fd_path ) = @$data_ref; $logger->trace("disp_leaf path is $path"); my $std_v = $leaf_object->fetch(qw/mode standard check no silent 1/); my $value = $leaf_object->fetch( check => 'no', silent => 1 ); my $tkt = $cw->{tktree}; my ( $is_customised, $img, $has_error, $has_warning ); { no warnings qw/uninitialized/; $is_customised = !!( defined $value and ( $std_v ne $value ) ); $img = $cust_img if $is_customised; $has_warning = !!$leaf_object->warning_msg; $img = $warn_img if $has_warning; $has_error = !!$leaf_object->error_msg; $img = $error_img if $has_error; } if ( defined $img ) { $tkt->itemCreate( $path, 1, -itemtype => 'image', -image => $img ); } else { # remove image when value is identical to standard value $tkt->itemDelete( $path, 1 ) if $tkt->itemExists( $path, 1 ); } $tkt->itemCreate( $path, 2, -text => $cw->trim_value($value) ); $tkt->itemCreate( $path, 3, -text => $cw->trim_value($std_v) ); } sub disp_node { my ( $scanner, $data_ref, $node, $element_name, $key, $contained_node ) = @_; my ( $path, $cw, $opening, $fd_path ) = @$data_ref; $logger->trace("disp_node path is $path"); my $curmode = $cw->{tktree}->getmode($path); $cw->{tktree}->setmode( $path, 'open' ) if $curmode eq 'none'; # explore next node $scanner->scan_node( $data_ref, $contained_node ); } sub setup_scanner { my ($cw) = @_; require Config::Model::ObjTreeScanner; my $scanner = Config::Model::ObjTreeScanner->new( fallback => 'node', check => 'no', # node callback node_content_cb => \&disp_obj_elt, # element callback list_element_cb => \&disp_hash, check_list_element_cb => \&disp_check_list, hash_element_cb => \&disp_hash, node_element_cb => \&disp_node, # leaf callback 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, uniline_value_cb => \&disp_leaf, reference_value_cb => \&disp_leaf, # call-back when going up the tree up_cb => sub { }, ); $cw->{scanner} = $scanner; } my %widget_table = ( edit => { leaf => 'ConfigModelLeafEditor', check_list => 'ConfigModelCheckListEditor', list => 'ConfigModelListEditor', hash => 'ConfigModelHashEditor', node => 'ConfigModelNodeEditor', }, view => { leaf => 'ConfigModelLeafViewer', check_list => 'ConfigModelCheckListViewer', list => 'ConfigModelListViewer', hash => 'ConfigModelHashViewer', node => 'ConfigModelNodeViewer', }, ); sub create_element_widget { my $cw = shift; my $mode = shift; my $tree_path = shift; # optional my $obj = shift; # optional if tree is not opened to path my $tree = $cw->{tktree}; unless ( defined $tree_path ) { # pointery and rooty are common widget method and must called on # the right widget to give accurate results $tree_path = $tree->nearest( $tree->pointery - $tree->rooty ); } if ( $tree->info( exists => $tree_path ) ) { $tree->selectionClear(); # clear all $tree->selectionSet($tree_path); my $data_ref = $tree->infoData($tree_path); unless ( defined $data_ref->[1] ) { $cw->reload; return; } $obj = $data_ref->[1]; weaken($obj); #my $loc = $data_ref->[1]->location; #$obj = $cw->{root}->grab($loc); } my $loc = $obj->location; my $type = $obj->get_type; $logger->trace("item $loc to $mode (type $type)"); my $e_frame = $cw->Subwidget('ed_frame'); # cleanup existing widget contained in this frame delete $cw->{editor}; map { $_->destroy if Tk::Exists($_) } $e_frame->children; my $widget = $widget_table{$mode}{$type} || die "Cannot find $mode widget for type $type"; my @store = $mode eq 'edit' ? ( -store_cb => sub { $cw->reload(@_) } ) : (); $cw->{current_mode} = $mode; my $tk_font = $cw->cget('-font'); $cw->{editor} = $e_frame->$widget( -item => $obj, -path => $tree_path, -font => $tk_font, @store, ); $cw->{editor}->ConfigSpecs( -font => ['DESCENDANTS', 'font','Font', $tk_font ]); $cw->{editor}->pack( -expand => 1, -fill => 'both' ); return $cw->{editor}; } sub edit_copy { my $cw = shift; my $tkt = $cw->{tktree}; my @selected = @_ ? @_ : $tkt->info('selection'); #print "edit_copy @selected\n"; my @res; foreach my $selection (@selected) { my $data_ref = $tkt->infoData($selection); my $cfg_elt = $data_ref->[1]; my $type = $cfg_elt->get_type; my $cfg_class = $type eq 'node' ? $cfg_elt->config_class_name : ''; #print "edit_copy '",$cfg_elt->location, "' type '$type' class '$cfg_class'\n"; push @res, [ $cfg_elt->element_name, $cfg_elt->index_value, $cfg_elt->composite_name, $type, $cfg_class, $cfg_elt->dump_as_data() ]; } $cw->{cut_buffer} = \@res; #use Data::Dumper; print "cut_buffer: ", Dumper( \@res ) ,"\n"; return \@res; # for tests } sub edit_paste { my $cw = shift; my $tkt = $cw->{tktree}; my @selected = @_ ? @_ : $tkt->info('selection'); return unless @selected; #print "edit_paste in @selected\n"; my @res; my $selection = $selected[0]; my $data_ref = $tkt->infoData($selection); my $cfg_elt = $data_ref->[1]; #print "edit_paste '",$cfg_elt->location, "' type '", $cfg_elt->get_type,"'\n"; my $t_type = $cfg_elt->get_type; my $t_class = $t_type eq 'node' ? $cfg_elt->config_class_name : ''; my $t_name = $cfg_elt->element_name; my $cut_buf = $cw->{cut_buffer} || []; foreach my $data (@$cut_buf) { my ( $name, $index, $composite, $type, $cfg_class, $dump ) = @$data; #print "from composite name '$composite' type $type\n"; #print "t_name '$t_name' t_type '$t_type' class '$t_class'\n"; if ( ( $name eq $t_name and $type eq $t_type ) or $t_class eq $cfg_class ) { $cfg_elt->load_data($dump); } elsif ( ( $t_type eq 'hash' or $t_type eq 'list' ) and defined $index ) { $cfg_elt->fetch_with_id($index)->load_data($dump); } elsif ( $t_type eq 'hash' or $t_type eq 'list' or $t_type eq 'leaf' ) { $cfg_elt->load_data($dump); } else { $cfg_elt->grab($composite)->load_data($dump); } } $cw->reload() if @$cut_buf; $cw->create_element_widget($cw->{current_mode}, $selection); } sub wizard { my $cw = shift; my $wiz = $cw->setup_wizard( sub { $cw->deiconify; $cw->raise; $cw->reload; } ); # hide main window while wizard is running # end_cb callback will raise the main window $cw->withdraw; $wiz->prepare_wizard(); } sub setup_wizard { my $cw = shift; my $end_sub = shift; # when wizard is run, there's no need to update editor window in # main widget my $tk_font = $cw->cget('-font'); return $cw->ConfigModelWizard( -root => $cw->{root}, -end_cb => $end_sub, -font => $tk_font, ); } # FIXME: need to be able to search different types. # 2 choices # - destroy and re-create the searcher when it's modified # - change the searcher (TreeSearcher) to accept type modif # For the latter: it would be better to accept a set of types instead of # all or just one type (to implement a set of check buttons) sub create_find_widget { my $cw = shift; my $f = $cw->Frame( -relief => 'ridge', -borderwidth => 1, ); my $remove_img = $cw->Photo( -file => $icon_path . 'remove.png' ); $f->Button( -image => $remove_img, -command => sub { $f->packForget(); }, -relief => 'flat', )->pack( -side => 'left' ); my $searcher = $cw->{root}->tree_searcher( type => 'all' ); my $search = ''; my @result; $f->Label( -text => 'Find: ' )->pack( -side => 'left' ); my $e = $f->Entry( -textvariable => \$search, -validate => 'key', # ditch the search results when find entry is modified. -validatecommand => sub { @result = (); return 1; }, )->pack( -side => 'left' ); $cw->Advertise( find_entry => $e ); foreach my $direction (qw/previous next/) { my $s = sub { $cw->find_item( $direction, $searcher, \$search, \@result ); }; $f->Button( -compound => 'left', -image => $gnome_img{$direction}, -text => ucfirst($direction), -command => $s, -relief => 'flat', )->pack( -side => 'left' ); } # bind Return (or Enter) key $e->bind( '', sub { $cw->find_item( 'next', $searcher, \$search, \@result ); } ); return $f; } sub pack_find_widget { my $cw = shift; $cw->Subwidget('find_frame')->pack( -anchor => 'w', -fill => 'x' ); $cw->Subwidget('find_entry')->focus; } sub find_item { my ( $cw, $direction, $searcher, $search_ref, $result ) = @_; my $find_frame = $cw->Subwidget('find_frame'); # search the tree, store the result @$result = $searcher->search($$search_ref) unless @$result; # and jump in the list widget any time next is hit. if (@$result) { if ( defined $cw->{old_path} and $direction eq 'next' ) { push @$result, shift @$result; } elsif ( defined $cw->{old_path} ) { unshift @$result, pop @$result; } my $path = $result->[0]; $cw->{old_path} = $path; $cw->force_element_display( $cw->{root}->grab($path) ); } } 1; __END__ =head1 NAME Config::Model::TkUI - Tk GUI to edit config data through Config::Model =head1 SYNOPSIS use Config::Model::TkUI; # init trace Log::Log4perl->easy_init($WARN); # create configuration instance my $model = Config::Model -> new ; my $inst = $model->instance (root_class_name => 'a_config_class', instance_name => 'test'); my $root = $inst -> config_root ; # Tk part my $mw = MainWindow-> new ; $mw->withdraw ; $mw->ConfigModelUI (-root => $root) ; MainLoop ; =head1 DESCRIPTION This class provides a GUI for L. With this class, L and an actual configuration model (like L), you get a tool to edit configuration files (e.g. C). =head1 USAGE =head2 Left side tree =over =item * Click on '+' and '-' boxes to open or close content =item * Left-click on item to open a viewer widget. =item * Double-click or hit "return" on any item to open an editor widget =item * Use Ctrl-C to copy configuration data in an internal buffer =item * Use Ctrl-V to copy configuration data from the internal buffer to the configuration tree. Beware, there's no "undo" operation. =item * Before saving your modifications, you can review the change list with the menu entry C<< File -> show unsaved changes >>. This list is cleared after performing a C<< File -> save >>. =item * Pasting cut buffer into: =over =item * a leaf element will store the content of the buffer into the element. =item * a list element will split the content of the buffer with /\n/ or /,/ and push the resulting array at the end of the list element. =item * a hash element will use the content of the cut buffer to create a new key in the hash element. =back =back =head2 Font size and big screens Font type and size can be adjusted using menu: "Options -> Font" menu. This setup is saved in file C<~/.cme/config/tkui.yml>. =head2 Search Hit C or use menu C<< Edit -> Search >> to open a search widget at the bottom of the window. Enter a keyword in the entry widget and click on C button. The keyword will be searched in the configuration tree, in element name, in element value and in documentation. =head2 Editor widget The right side of the widget is either a viewer or an editor. When clicking on store in the editor, the new data is stored in the tree represented on the left side of TkUI. The new data will be stored in the configuration file only when Csave> menu is invoked. =head2 Wizard A wizard can be launched either with C<< File -> Wizard >> menu entry or with C button. The wizard will scan the configuration tree and stop on all items flagged as important in the model. It will also stop on all erroneous items (mostly missing mandatory values). =head1 Methods =head2 save(callback) Save modified data in configuration file. The callback function is called only if the save was done without error. The callback is called with C<$@> in case of failed save. =head1 TODO - add tabular view ? - expand the whole tree at once - add plug-in mechanism so that dedicated widget can be used for some config Class (Could be handy for Xorg::ServerLayout) =head1 More information =over =item * See L =item * Or L where you can find many post about L. =item * Send a mail to Config::Model user mailing list: config-model-users at lists.sourceforge.net =back =head1 FEEDBACK and HELP wanted This project needs feedback from its users. Please send your feedbacks, comments and ideas to : config-mode-users at lists.sourceforge.net This projects also needs help to improve its user interfaces: =over =item * Look and feel of Perl/Tk interface can be improved =item * A nicer logo (maybe a penguin with a wrench...) would be welcomed =item * Config::Model could use a web interface =item * May be also an interface based on Gtk or Wx for better integration in Desktop =back If you want to help, please send a mail to: config-mode-devel at lists.sourceforge.net =head1 SEE ALSO =over =item * L, L =item * https://github.com/dod38fr/config-model-tkui/wiki =item * Config::Model mailing lists on http://sourceforge.net/mail/?group_id=155650 =back Config-Model-TkUI-1.365/lib/Config/Model/Tk/0000755000175000017500000000000013204357016016641 5ustar domidomiConfig-Model-TkUI-1.365/lib/Config/Model/Tk/ListEditor.pm0000644000175000017500000003443313204357016021270 0ustar domidomi# # This file is part of Config-Model-TkUI # # This software is Copyright (c) 2008-2017 by Dominique Dumont. # # This is free software, licensed under: # # The GNU Lesser General Public License, Version 2.1, February 1999 # package Config::Model::Tk::ListEditor; $Config::Model::Tk::ListEditor::VERSION = '1.365'; use strict; use warnings; use Carp; use Log::Log4perl; use base qw/Config::Model::Tk::ListViewer/; use subs qw/menu_struct/; use vars qw/$icon_path/; use Tk::Dialog; use Config::Model::Tk::NoteEditor; Construct Tk::Widget 'ConfigModelListEditor'; my @fbe1 = qw/-fill both -expand 1/; my @fxe1 = qw/-fill x -expand 1/; my @fx = qw/-fill x /; my $logger = Log::Log4perl::get_logger("Tk::ListEditor"); my ( $up_img, $down_img, $rm_img, $eraser_img, $remove_img, $sort_img ); *icon_path = *Config::Model::TkUI::icon_path; my $entry_width = 20; sub ClassInit { my ( $cw, $args ) = @_; # ClassInit is often used to define bindings and/or other # resources shared by all instances, e.g., images. # cw->Advertise(name=>$widget); } sub Populate { my ( $cw, $args ) = @_; my $list = $cw->{list} = delete $args->{-item} || die "ListEditor: no -item, got ", keys %$args; delete $args->{-path}; my $cme_font = delete $args->{-font}; $cw->{store_cb} = delete $args->{-store_cb} or die __PACKAGE__, "no -store_cb"; unless ( defined $up_img ) { $up_img = $cw->Photo( -file => $icon_path . 'up.png' ); $down_img = $cw->Photo( -file => $icon_path . 'down.png' ); $eraser_img = $cw->Photo( -file => $icon_path . 'eraser.png' ); $remove_img = $cw->Photo( -file => $icon_path . 'remove.png' ); $sort_img = $cw->Photo( -file => $icon_path . 'dbgrun.png' ); } $cw->add_header( Edit => $list )->pack(@fx); my $balloon = $cw->Balloon( -state => 'balloon' ); my $inst = $list->instance; my $value_type = $list->get_cargo_info('value_type'); # may be undef my $elt_button_frame = $cw->Frame(qw/-relief raised -borderwidth 2/)->pack(@fbe1); my $frame_title = $list->element_name; $frame_title .= ( defined $value_type and $value_type =~ /node/ ) ? ' elements' : ' list'; $elt_button_frame->Label( -text => $frame_title )->pack(); my $tklist = $elt_button_frame->Scrolled( 'Listbox', -selectmode => 'single', -scrollbars => 'oe', -height => 8, )->pack(@fbe1); $balloon->attach( $tklist, -msg => 'select an element and perform an action with one of the buttons below' ); my $right_frame = $elt_button_frame->Frame->pack( @fxe1, qw/-side right -anchor n/ ); $cw->ConfigModelNoteEditor( -object => $list )->pack; $cw->add_summary($list)->pack(@fx); $cw->add_description($list)->pack(@fbe1); $cw->add_warning( $list, 'edit' )->pack(@fx); $cw->add_info_button($cw)->pack(@fx); my $mv_rm_frame = $right_frame->Frame->pack(@fx); my $move_up_b = $mv_rm_frame->Button( -image => $up_img, -command => sub { $cw->move_up; }, )->pack( -side => 'left', @fxe1 ); $balloon->attach( $move_up_b, -msg => 'Move selected element up the list' ); my $move_down_b = $mv_rm_frame->Button( -image => $down_img, -command => sub { $cw->move_down; }, )->pack( -side => 'left', @fxe1 ); $balloon->attach( $move_down_b, -msg => 'Move selected element down the list' ); my $eraser_b = $mv_rm_frame->Button( -image => $eraser_img, -command => sub { $cw->remove_selection; }, )->pack( -side => 'left', @fxe1 ); $balloon->attach( $eraser_b, -msg => 'Remove selected element from the list' ); my $rm_all_b = $mv_rm_frame->Button( -image => $remove_img, -command => sub { $list->clear; $tklist->delete( 0, 'end' ); $cw->{store_cb}->(); }, )->pack( -side => 'left', @fxe1 ); $balloon->attach( $rm_all_b, -msg => 'Remove all elements from the list' ); my $cargo_type = $list->cargo_type; if ( $cargo_type eq 'leaf' ) { my $sort_b = $mv_rm_frame->Button( -image => $sort_img, -command => sub { $cw->sort_content } )->pack( -side => 'left', @fxe1 ); $balloon->attach( $sort_b, -msg => 'Sort all elements in the list' ); } if ( $cargo_type eq 'leaf' and $value_type ne 'enum' and $value_type ne 'reference' ) { my $set_push_b_entry_frame = $right_frame->Frame( -borderwidth => 2, -relief => 'groove' )->pack(@fxe1); my $user_value; my $value_entry = $set_push_b_entry_frame->Entry( -textvariable => \$user_value, -width => $entry_width ); my $set_push_b_frame = $set_push_b_entry_frame->Frame->pack(@fxe1); $cw->add_set_entry( $set_push_b_frame, $balloon, $tklist, \$user_value )->pack(@fxe1); $cw->add_insort_entry( $set_push_b_frame, $balloon, \$user_value )->pack(@fxe1); $cw->add_insert_entry( $set_push_b_frame, $balloon, \$user_value )->pack(@fxe1); $cw->add_set_all_b( $set_push_b_entry_frame, $set_push_b_frame, $balloon, \$user_value ) ->pack(@fxe1); $value_entry->pack(@fxe1); $cw->add_warning( $list, 'edit' )->pack(@fx); } else { my $elt_name = $list->element_name; my $disp = "$elt_name ( $cargo_type "; $disp .= $list->config_class_name . ' )' if $cargo_type eq 'node'; $disp .= " $value_type )" if defined $value_type; my $b = $right_frame->Button( -text => "Push new $disp", -command => sub { $cw->push_entry(''); }, )->pack(@fxe1); $balloon->attach( $b, -msg => "add a new $elt_name at the end of the list" ); } $cw->{tklist} = $tklist; $cw->reset_value; $cw->ConfigSpecs(-font => [['SELF','DESCENDANTS'], 'font','Font', $cme_font ],); $cw->Tk::Frame::Populate($args); } # # New subroutine "reset_value" extracted - Wed Sep 21 11:33:51 2011. # sub reset_value { my $cw = shift; my $list = $cw->{list}; my $cargo_type = $list->cargo_type; $cw->{tklist}->delete( 0, 'end' ); my @insert = $cargo_type eq 'leaf' ? $list->fetch_all_values( check => 'no' ) : $list->fetch_all_indexes; map { $_ = '' unless defined $_ } @insert; $cw->{tklist}->insert( end => @insert ); return ( $cargo_type, \@insert ); } sub add_set_entry { my ( $cw, $frame, $balloon, $tklist, $user_value_r ) = @_; my $set_sub = sub { $cw->set_entry($$user_value_r); }; my $set_b = $frame->Button( -text => "set selected", -command => $set_sub, )->pack( -side => 'left', @fxe1 ); $balloon->attach( $set_b, -msg => 'enter a value, select an element on the left ' . 'and click the button to replace the selected ' . 'element with this value.' ); my $b_sub = sub { my $idx = $tklist->curselection; $$user_value_r = $tklist->get($idx) if $idx; }; $tklist->bind( '<>', $b_sub ); return $set_b; } sub add_push_entry { my ( $cw, $frame, $balloon, $user_value_r ) = @_; my $push_sub = sub { $cw->push_entry($$user_value_r); $$user_value_r = ''; }; my $push_b = $frame->Button( -text => "push item", -command => $push_sub, )->pack( -side => 'left', @fxe1 ); $balloon->attach( $push_b, -msg => 'enter a value, and click the push button to add ' . 'this value at the end of the list' ); return $push_b; } sub push_entry { my $cw = shift; my $add = shift; my $tklist = $cw->{tklist}; my $list = $cw->{list}; $logger->debug("push_entry: $add"); # create new item in list (may auto create node object) my @idx = $list->fetch_all_indexes; eval { $list->fetch_with_id( scalar @idx ) }; if ($@) { $cw->Dialog( -title => "List index error", -text => $@->as_string, )->Show; } else { # trigger redraw of Tk Tree $cw->{store_cb}->(); my @new_idx = $list->fetch_all_indexes; $logger->debug( "new list idx: " . join( ',', @new_idx ) ); my $insert = length($add) ? $add : $#new_idx; $tklist->insert( 'end', $insert ); } return 1; } sub add_insert_entry { my ( $cw, $frame, $balloon, $user_value_r ) = @_; my $insert_sub = sub { $cw->insert_entry($$user_value_r); $$user_value_r = ''; }; my $insert_b = $frame->Button( -text => "insert item", -command => $insert_sub, )->pack( -side => 'left', @fxe1 ); $balloon->attach( $insert_b, -msg => 'enter a value, and click the insert button to add ' . 'this value before the selected item or at the end of the list (push)' ); return $insert_b; } sub insert_entry { my $cw = shift; my $add = shift; my $tklist = $cw->{tklist}; my $list = $cw->{list}; my $idx_ref = $tklist->curselection || []; my $idx = $idx_ref->[0]; $logger->debug( "insert_entry: $add insert at index ", $idx || 'end' ); print( "insert_entry: $add insert at index ", $idx || 'end', "\n" ); return unless length($add); my $try_sub = defined $idx ? sub { $list->insert_at( $idx, $add ); } : sub { $list->push($add) }; $cw->try_and_redraw($try_sub); } sub set_entry { my $cw = shift; my $data = shift; my $tklist = $cw->{tklist}; my $idx_ref = $tklist->curselection(); return unless defined $idx_ref; return unless @$idx_ref; my $idx = $idx_ref->[0]; return unless $idx; $tklist->delete($idx); $tklist->insert( $idx, $data ); $tklist->selectionSet($idx); $cw->{list}->fetch_with_id($idx)->store($data); $cw->{store_cb}->(); } sub add_insort_entry { my ( $cw, $frame, $balloon, $user_value_r ) = @_; my $insort_sub = sub { $cw->insort_entry($$user_value_r); $$user_value_r = ''; }; my $insort_b = $frame->Button( -text => "insort", -command => $insort_sub, )->pack( -side => 'left', @fxe1 ); $balloon->attach( $insort_b, -msg => 'enter a value, and click the insort button to insert ' . 'this value while keeping the list sorted' ); return $insort_b; } sub insort_entry { my $cw = shift; my $add = shift; $logger->debug("insort_entry: $add"); return unless length($add); $cw->try_and_redraw( sub { $cw->{list}->insort($add); } ); } sub try_and_redraw { my $cw = shift; my $to_try = shift; my $tklist = $cw->{tklist}; my $list = $cw->{list}; eval { $to_try->(); }; if ($@) { $cw->Dialog( -title => "List index error", -text => $@->as_string, )->Show; } else { # trigger redraw of Tk Tree $cw->{store_cb}->(); my @list = $list->fetch_all_values; $tklist->delete( 0, 'end' ); $tklist->insert( 0, @list ); } return 1; } sub add_set_all_b { my ( $cw, $frame, $b_frame, $balloon, $user_value_r ) = @_; my $regexp = '\s*,\s*'; my $set_all_sub = sub { $cw->set_all_items( $$user_value_r, $regexp ); }; #my $set_all_frame = $frame->Frame; #my $set_top = $set_all_frame->Frame->pack(@fxe1); my $set_bottom = $frame->Frame->pack( @fxe1, -side => 'bottom' ); my $set_b = $b_frame->Button( -text => "set all", -command => $set_all_sub, )->pack( -side => 'left', @fx ); $balloon->attach( $set_b, -msg => 'set all elements with a single string that ' . 'will be split by the regexp displayed below' ); my $split_lb = $set_bottom->Label( -text => 'split regexp' )->pack( -side => 'left', @fxe1 ); $set_bottom->Entry( -textvariable => \$regexp )->pack( -side => 'left', @fxe1 ); $balloon->attach( $split_lb, -msg => 'regexp used to split the entry above when "set all" button is pressed' ); return $set_bottom; } sub set_all_items { my $cw = shift; my $data = shift; my $regexp = shift; return unless $data; my $tklist = $cw->{tklist}; my @list = split /$regexp/, $data; $tklist->delete( 0, 'end' ); $tklist->insert( 0, @list ); $cw->{list}->load_data( \@list ); $cw->{store_cb}->(); } sub sort_content { my $cw = shift; my $tklist = $cw->{tklist}; my $list = $cw->{list}; $list->sort; my @list = $list->fetch_all_values; $tklist->delete( 0, 'end' ); $tklist->insert( 0, @list ); $cw->{store_cb}->(); } sub move_up { my $cw = shift; my $tklist = $cw->{tklist}; my $from_idx_ref = $tklist->curselection(); return unless defined $from_idx_ref; return unless @$from_idx_ref; my $from_idx = $from_idx_ref->[0]; return unless $from_idx; return unless $from_idx > 0; $cw->swap( $from_idx, $from_idx - 1 ); } sub move_down { my $cw = shift; my $tklist = $cw->{tklist}; my $from_idx_ref = $tklist->curselection(); return unless defined $from_idx_ref; return unless @$from_idx_ref; my $from_idx = $from_idx_ref->[0]; my $max_idx = $cw->{list}->fetch_size - 1; return unless $from_idx < $max_idx; $cw->swap( $from_idx, $from_idx + 1 ); } sub swap { my ( $cw, $ida, $idb ) = @_; my $tklist = $cw->{tklist}; my $list = $cw->{list}; $list->swap( $ida, $idb ); my $cargo_type = $list->cargo_type; $tklist->selectionClear($ida); if ( $cargo_type ne 'node' ) { my $old = $tklist->get($ida); $tklist->delete($ida); while ( $idb > $tklist->size ) { $tklist->insert( 'end', '' ); } $tklist->insert( $idb, $old ); } $tklist->selectionSet($idb); $cw->{store_cb}->(); } sub remove_selection { my $cw = shift; my $tklist = $cw->{tklist}; my $list = $cw->{list}; foreach ( $tklist->curselection() ) { $logger->debug("remove_selection: removing index $_"); $list->remove($_); } $cw->{store_cb}->(); # redraw the list content $tklist->delete( 0, 'end' ); my $cargo_type = $list->cargo_type; my @insert = $cargo_type eq 'leaf' ? $list->fetch_all_values( check => 'no' ) : $list->fetch_all_indexes; map { $_ = '' unless defined $_ } @insert; $tklist->insert( end => @insert ); $cw->update_warning($list); } 1; Config-Model-TkUI-1.365/lib/Config/Model/Tk/CheckListViewer.pm0000644000175000017500000000666313204357016022245 0ustar domidomi# # This file is part of Config-Model-TkUI # # This software is Copyright (c) 2008-2017 by Dominique Dumont. # # This is free software, licensed under: # # The GNU Lesser General Public License, Version 2.1, February 1999 # package Config::Model::Tk::CheckListViewer; $Config::Model::Tk::CheckListViewer::VERSION = '1.365'; use strict; use warnings; use Carp; use base qw/Tk::Frame Config::Model::Tk::AnyViewer/; use subs qw/menu_struct/; use Tk::ROText; Construct Tk::Widget 'ConfigModelCheckListViewer'; my @fbe1 = qw/-fill both -expand 1/; my @fxe1 = qw/-fill x -expand 1/; my @fx = qw/-fill x/; sub ClassInit { my ( $cw, $args ) = @_; # ClassInit is often used to define bindings and/or other # resources shared by all instances, e.g., images. # cw->Advertise(name=>$widget); } sub Populate { my ( $cw, $args ) = @_; my $leaf = $cw->{leaf} = delete $args->{-item} || die "CheckListViewer: no -item, got ", keys %$args; my $path = delete $args->{-path} || die "CheckListViewer: no -path, got ", keys %$args; my $cme_font = delete $args->{-font}; my $inst = $leaf->instance; $cw->add_header( View => $leaf )->pack(@fx); my $rt = $cw->Scrolled( 'ROText', -scrollbars => 'osoe', -height => 6, )->pack(@fbe1); $rt->tagConfigure( 'in', -background => 'black', -foreground => 'white' ); my %h = $leaf->get_checked_list_as_hash; foreach my $c ( $leaf->get_choice ) { my $tag = $h{$c} ? 'in' : 'out'; $rt->insert( 'end', $c . "\n", $tag ); } $cw->add_annotation($leaf)->pack(@fx); $cw->add_summary($leaf)->pack(@fx); my ( $help_frame, $help_widget ) = $cw->add_help( value => '', 1 ); $help_frame->pack(@fx); $cw->{value_help_widget} = $help_widget; $cw->set_value_help( $leaf->get_checked_list ); $cw->add_description($leaf)->pack(@fbe1); $cw->add_info_button()->pack( @fxe1, -side => 'left' ); $cw->add_editor_button($path)->pack( @fxe1, -side => 'right' ); $cw->ConfigSpecs( -font => [['SELF','DESCENDANTS'], 'font','Font', $cme_font ], #-fill => [ qw/SELF fill Fill both/], #-expand => [ qw/SELF expand Expand 1/], -relief => [qw/SELF relief Relief groove/], -borderwidth => [qw/SELF borderwidth Borderwidth 2/], DEFAULT => [qw/SELF/], ); $cw->SUPER::Populate($args); } sub add_value_help { my $cw = shift; my $help_frame = $cw->Frame( -relief => 'groove', -borderwidth => 2, )->pack(@fbe1); my $leaf = $cw->{leaf}; $help_frame->Label( -text => 'value help: ' )->pack( -side => 'left' ); $help_frame->Label( -textvariable => \$cw->{help} ) ->pack( -side => 'left', -fill => 'x', -expand => 1 ); } sub set_value_help { my $cw = shift; my @set = @_; my $w = $cw->{value_help_widget}; $w->delete( '0.0', 'end' ); # in pod text, =encoding must be specified only once $w->insert( 'end', "=encoding utf8\n\n"); foreach my $v (@set) { my $value_help = $cw->{leaf}->get_help($v); $w->insert( 'end', "$v: " . $value_help . "\n" ) if defined $value_help; } } sub get_info { my $cw = shift; my @items = (); my $leaf = $cw->{leaf}; if ( defined $leaf->refer_to ) { push @items, "refer_to: " . $leaf->refer_to; } push @items, "ordered: " . ( $leaf->ordered ? 'yes' : 'no' ); return $leaf->element_name, @items; } 1; Config-Model-TkUI-1.365/lib/Config/Model/Tk/NodeViewer.pm0000644000175000017500000001043213204357016021246 0ustar domidomi# # This file is part of Config-Model-TkUI # # This software is Copyright (c) 2008-2017 by Dominique Dumont. # # This is free software, licensed under: # # The GNU Lesser General Public License, Version 2.1, February 1999 # package Config::Model::Tk::NodeViewer; $Config::Model::Tk::NodeViewer::VERSION = '1.365'; use strict; use warnings; use Carp; use 5.10.1; use base qw/Tk::Frame Config::Model::Tk::AnyViewer/; use subs qw/menu_struct/; Construct Tk::Widget 'ConfigModelNodeViewer'; my @fbe1 = qw/-fill both -expand 1/; my @fxe1 = qw/-fill x -expand 1/; my @fx = qw/-fill x /; sub ClassInit { my ( $cw, $args ) = @_; # ClassInit is often used to define bindings and/or other # resources shared by all instances, e.g., images. # cw->Advertise(name=>$widget); } sub Populate { my ( $cw, $args ) = @_; my $node = $cw->{node} = delete $args->{-item} || die "NodeViewer: no -item, got ", keys %$args; my $path = delete $args->{-path}; my $cme_font = delete $args->{-font}; $cw->add_header( View => $node )->pack(@fx); my $inst = $node->instance; my $elt_frame = $cw->Frame(qw/-relief flat/)->pack(@fbe1); $elt_frame->Label( -text => $node->composite_name_short . ' node elements' )->pack(); my $hl = $elt_frame->Scrolled( 'HList', -scrollbars => 'osow', -columns => 3, -header => 1, -height => 8, )->pack(@fbe1); $hl->headerCreate( 0, -text => 'name' ); $hl->headerCreate( 1, -text => 'type' ); $hl->headerCreate( 2, -text => 'value' ); $cw->{hlist} = $hl; $cw->reload; # add adjuster. Buggy behavior on destroy... #require Tk::Adjuster; #$cw->{adjust} = $cw -> Adjuster(); #$cw->{adjust}->packAfter($hl, -side => 'top') ; $cw->add_annotation($node)->pack(@fx); if ( $node->parent ) { $cw->add_summary($node)->pack(@fx); $cw->add_description($node)->pack(@fbe1); } else { $cw->add_help( class => $node->get_help )->pack(@fx); } $cw->add_info_button()->pack( @fxe1, -side => 'left' ); $cw->add_editor_button($path)->pack( @fxe1, -side => 'right' ); $cw->ConfigSpecs(-font => [['SELF','DESCENDANTS'], 'font','Font', $cme_font ],); $cw->SUPER::Populate($args); } #sub DESTROY { # my $cw = shift ; # $cw->{adjust}->packForget(1); #} sub reload { my $cw = shift; my $node = $cw->{node}; my $hl = $cw->{hlist}; my %old_elt = %{ $cw->{elt_path} || {} }; foreach my $elt_name ( $node->get_element_name() ) { my $hl_name = $elt_name; $hl_name =~ s/\./__/g; # make elt name compatible with Tk::HList my $type = $node->element_type($elt_name); unless ( delete $old_elt{$hl_name} ) { # create item $hl->add($hl_name); $cw->{elt_path}{$hl_name} = 1; $hl->itemCreate( $hl_name, 0, -text => $elt_name ); $hl->itemCreate( $hl_name, 1, -text => $type ); $hl->itemCreate( $hl_name, 2, -itemtype => 'imagetext', -text => '', -showimage => 0, -image => $Config::Model::TkUI::warn_img ); } if ( $type eq 'leaf' ) { # update displayed value my $v = eval { $node->fetch_element_value($elt_name) }; if ($@) { $hl->itemConfigure( $hl_name, 2, -showtext => 0, -showimage => 1, ); } elsif ( defined $v ) { substr( $v, 15 ) = '...' if length($v) > 15; $hl->itemConfigure( $hl_name, 2, -showtext => 1, -showimage => 0, -text => $v ); } } } # destroy leftover widgets (may occur with warp mechanism) map { $hl->delete( entry => $_ ); } keys %old_elt; } sub get_info { my $cw = shift; my $node = $cw->{node}; my @items = ( 'type : ' . $node->get_type, 'class name : ' . $node->config_class_name, ); my @rexp = $node->accept_regexp; if (@rexp) { push @items, 'accept : /^' . join( '$/, /^', @rexp ) . '$/'; } return $node->element_name, @items; } 1; Config-Model-TkUI-1.365/lib/Config/Model/Tk/Wizard.pm0000644000175000017500000002070113204357016020437 0ustar domidomi# # This file is part of Config-Model-TkUI # # This software is Copyright (c) 2008-2017 by Dominique Dumont. # # This is free software, licensed under: # # The GNU Lesser General Public License, Version 2.1, February 1999 # package Config::Model::Tk::Wizard; $Config::Model::Tk::Wizard::VERSION = '1.365'; use strict; use warnings; use Carp; use Try::Tiny; use base qw/Tk::Toplevel/; use vars qw/$icon_path/; use Log::Log4perl; use Config::Model::Tk::LeafEditor; use Config::Model::Tk::CheckListEditor; use Config::Model::Tk::ListEditor; use Config::Model::Tk::HashEditor; Construct Tk::Widget 'ConfigModelWizard'; my $logger = Log::Log4perl::get_logger('Tk::Wizard'); my @fbe1 = qw/-fill both -expand 1/; my @fxe1 = qw/-fill x -expand 1/; my @fx = qw/-fill x /; sub ClassInit { my ( $class, $mw ) = @_; # ClassInit is often used to define bindings and/or other # resources shared by all instances, e.g., images. # cw->Advertise(name=>$widget); } sub Populate { my ( $cw, $args ) = @_; foreach my $parm (qw/-root/) { my $attr = $parm; $attr =~ s/^-//; $cw->{$attr} = delete $args->{$parm} or croak "Missing $parm arg\n"; } foreach my $parm (qw/-from_widget -stop_on_important -store_cb -show_cb -end_cb -font/) { my $attr = $parm; $attr =~ s/^-//; $cw->{$attr} = delete $args->{$parm}; } $logger->info("Creating wizard widget"); $cw->{show_cb} ||= sub { }; $cw->{store_cb} ||= sub { }; $cw->{has_stopped} = 0; my $title = delete $args->{'-title'} || "config wizard " . $cw->{root}->config_class_name; $cw->Label( -text => "Configuration of " . $cw->{root}->config_class_name, )->pack; my $ed = $cw->{ed_frame} = $cw->Frame->pack(qw/-pady 0 -fill both -expand 1 -anchor n/); $cw->{ed_frame}->packPropagate(0); $args->{-title} = $title; $cw->Advertise( ed_frame => $ed, ); $cw->ConfigSpecs( -font => [['SELF','DESCENDANTS'], 'font','Font', $cw->{font} ], #-background => ['DESCENDANTS', 'background', 'Background', $background], #-selectbackground => [$hlist, 'selectBackground', 'SelectBackground', # $selectbackground], -width => [ $ed, undef, undef, 600 ], -height => [ $ed, undef, undef, 400 ], DEFAULT => [$ed] ); $cw->{font} //= $cw->cget('-font'); $cw->SUPER::Populate($args); } sub save { my $cw = shift; $cw->check(); $logger->info("Saving data in default directory with instance write_back"); $cw->{root}->instance->write_back(); } sub leaf_cb { my ( $cw, $scanner, $data_ref, $node, $element_name, $index, $leaf_object ) = @_; $cw->{has_stopped} = 1; # cleanup existing widget contained in this frame $cw->{show_cb}->($leaf_object); $cw->{ed_w} = $cw->{ed_frame}->ConfigModelLeafEditor( -item => $leaf_object, -store_cb => $cw->{store_cb}, -font => $cw->{font}, )->pack(@fbe1); } sub list_element_cb { my ( $cw, $scanner, $data_ref, $node, $element_name, @indexes ) = @_; $cw->{has_stopped} = 1; # cleanup existing widget contained in this frame my $obj = $node->fetch_element($element_name); $cw->{show_cb}->($obj); $cw->{ed_w} = $cw->{ed_frame}->ConfigModelListEditor( -item => $obj, -store_cb => $cw->{store_cb}, -font => $cw->{font}, )->pack(@fbe1); } sub hash_element_cb { my ( $cw, $scanner, $data_ref, $node, $element_name, @keys ) = @_; $cw->{has_stopped} = 1; # cleanup existing widget contained in this frame my $obj = $node->fetch_element($element_name); $cw->{show_cb}->($obj); $cw->{ed_w} = $cw->{ed_frame}->ConfigModelHashEditor( -item => $obj, -store_cb => $cw->{store_cb}, -font => $cw->{font}, )->pack(@fbe1); } sub check_list_element_cb { my ( $cw, $scanner, $data_ref, $node, $element_name, @items ) = @_; $cw->{has_stopped} = 1; # cleanup existing widget contained in this frame my $obj = $node->fetch_element($element_name); $cw->{show_cb}->($obj); $cw->{ed_w} = $cw->{ed_frame}->ConfigModelCheckListEditor( -item => $obj, -store_cb => $cw->{store_cb}, -font => $cw->{font}, )->pack(@fbe1); } sub prepare_wizard { my ( $cw, %args ) = @_; my $text = 'The wizard will scan all configuration items and stop on ' . '"important" items or on error (like missing mandatory values). If no ' . '"important" item and no error are found, the wizard will exit immediately'; my $edf = $cw->{ed_frame}; my $textw = $edf->ROText( qw/-relief flat -wrap word -height 8/, -font => $cw->{font}); $textw->insert( end => $text ); $textw->pack( qw/-side top -anchor n/, @fxe1 ); my $stop_on_warn = 0; $edf->Checkbutton( -text => 'stop on warning', -variable => \$stop_on_warn , -font => $cw->{font}) ->pack(qw/-side top -anchor w/); $edf->Button( -text => 'OK', -font => $cw->{font}, -command => sub { $cw->start_wizard($stop_on_warn) } )->pack(qw/-side right -anchor e/); $edf->Button( -text => 'cancel', -font => $cw->{font}, -command => sub { $cw->destroy_wizard() } )->pack(qw/-side left -anchor w/); } sub start_wizard { my ( $cw, %args ) = @_; my $button_f = $cw->Frame->pack(qw/-pady 0 -fill x -expand 1/); $cw->{has_stopped} = 0; my $back = $button_f->Button( -text => 'Back', -font => $cw->{font}, -command => sub { $cw->{keep_wiz_editor} = 0; $cw->{ed_w}->store if $cw->{ed_w}->can('store'); $cw->{wizard}->go_backward; } ); $back->pack(qw/-side left -fill x -expand 1/); my $stop = $button_f->Button( -text => 'Store and stop', -font => $cw->{font}, -command => sub { $cw->{ed_w}->store if $cw->{ed_w}->can('store'); $cw->{keep_wiz_editor} = 0; $cw->{wizard}->bail_out; } ); $stop->pack(qw/-side left -fill x -expand 1/); my $quit = $button_f->Button( -text => 'quit wizard', -font => $cw->{font}, -command => sub { $cw->{keep_wiz_editor} = 0; $cw->{wizard}->bail_out; } ); $quit->pack(qw/-side left -fill x -expand 1/); my $forw = $button_f->Button( -text => 'Next', -font => $cw->{font}, -command => sub { $cw->{keep_wiz_editor} = 0; $cw->{ed_w}->store if $cw->{ed_w}->can('store'); $cw->{wizard}->go_forward; } ); $forw->pack(qw/-side right -fill x -expand 1/); my ( $sort_element, $sort_idx ); $cw->{keep_wiz_editor} = 1; my %cb_table; # a local event loop is run within the call-back foreach my $cb_key ( qw/leaf_cb check_list_element_cb list_element_cb hash_element_cb/ ) { $cb_table{$cb_key} = sub { my ( $scanner, $data_ref, $node, $element_name ) = @_; my @all_args = @_; # @_ does not work in try blocks $logger->info( "$cb_key (element $element_name) called on '", $node->name, "'->'$element_name'" ); map { $_->destroy if Tk::Exists($_) } $cw->{ed_frame}->children; $cw->{keep_wiz_editor} = 1; try { $cw->$cb_key(@all_args); } catch { $cw->{keep_wiz_editor} = 0; # destroy wizard in case of error }; my $loop_c = 0; $logger->debug( "$cb_key wizard entered local loop ", ++$loop_c ); $cw->DoOneEvent() while $cw->{keep_wiz_editor}; $logger->debug( "$cb_key wizard exited local loop ", $loop_c ); }; } my @wiz_args = ( %cb_table ); foreach (qw/warning important/) { push @wiz_args, "call_back_on_$_" => $args{"stop_on_$_"} if defined $args{"stop_on_$_"}; } #Tk::ObjScanner::scan_object(\@wiz_args) ; $cw->{wizard} = $cw->{root}->instance->iterator(@wiz_args); # exits when wizard is done $cw->{wizard}->start; $cw->destroy_wizard; } sub destroy_wizard { my $cw = shift; delete $cw->{ed_w}; delete $cw->{wizard}; # print "Destroying wizard\n" ; $logger->debug("Destroying wizard"); $cw->destroy; if ( defined $cw->{end_cb} ) { $logger->debug("Calling end_cb"); $cw->{end_cb}->( $cw->{has_stopped} ); } } 1; Config-Model-TkUI-1.365/lib/Config/Model/Tk/NoteEditor.pm0000644000175000017500000000514213204357016021255 0ustar domidomi# # This file is part of Config-Model-TkUI # # This software is Copyright (c) 2008-2017 by Dominique Dumont. # # This is free software, licensed under: # # The GNU Lesser General Public License, Version 2.1, February 1999 # package Config::Model::Tk::NoteEditor; $Config::Model::Tk::NoteEditor::VERSION = '1.365'; use strict; use warnings; use Carp; use Log::Log4perl; use base qw/Tk::Frame/; use vars qw/$icon_path/; use subs qw/menu_struct/; use Tk::Dialog; use Tk::Photo; use Tk::Balloon; use Tk; # Needed to import Ev function Construct Tk::Widget 'ConfigModelNoteEditor'; my @fbe1 = qw/-fill both -expand 1/; my @fxe1 = qw/-fill x -expand 1/; my @fx = qw/-fill x /; my $logger = Log::Log4perl::get_logger(__PACKAGE__); sub ClassInit { my ( $cw, $args ) = @_; # ClassInit is often used to define bindings and/or other # resources shared by all instances, e.g., images. # cw->Advertise(name=>$widget); } # This widget is to be integrated directly in a ConfigModel editor widget sub Populate { my ( $cw, $args ) = @_; my $obj = delete $args->{-object} || croak "NoteEditor: no -object option, got ", join( ',', keys %$args ); return unless $obj->backend_support_annotation ; my $label = 'Edit Note'; my $status = $label; my $note_w; my $cme_font = delete $args->{-font}; my $save_cb = sub { $obj->annotation( $note_w->Contents ); $status = $label; }; my $del_cb = sub { $obj->clear_annotation; $note_w->Contents(''); $status = $label; }; my $updated_cb = sub { my $k = Ev('k'); $status = $label . '*'; }; my $ed_frame = $cw->Frame->pack(); my $ctrl_frame = $ed_frame->Frame->pack( -side => 'left' ); $ctrl_frame->Label( -textvariable => \$status )->pack(); $ctrl_frame->Button( -text => 'save note', -command => $save_cb )->pack( -fill => 'x' ); $ctrl_frame->Button( -text => 'del note', -command => $del_cb )->pack( -fill => 'x' ); $note_w = $ed_frame->Scrolled( 'Text', -height => 5, -scrollbars => 'ow', )->pack( @fbe1, -anchor => 's', -side => 'bottom' ); my $balloon = $ed_frame->Balloon( -state => 'balloon' ); $balloon->attach( $note_w, -msg => 'You may enter a comment here' ); # read annotation and set up a callback to save user's entry at # every return $note_w->Contents( $obj->annotation ); $note_w->bind( '', $updated_cb ); $note_w->bind( '', $updated_cb ); $cw->ConfigSpecs(-font => [['SELF','DESCENDANTS'], 'font','Font', $cme_font ],); $cw->SUPER::Populate($args); } 1; Config-Model-TkUI-1.365/lib/Config/Model/Tk/ListViewer.pm0000644000175000017500000000547113204357016021303 0ustar domidomi# # This file is part of Config-Model-TkUI # # This software is Copyright (c) 2008-2017 by Dominique Dumont. # # This is free software, licensed under: # # The GNU Lesser General Public License, Version 2.1, February 1999 # package Config::Model::Tk::ListViewer; $Config::Model::Tk::ListViewer::VERSION = '1.365'; use strict; use warnings; use Carp; use base qw/Tk::Frame Config::Model::Tk::AnyViewer/; use subs qw/menu_struct/; Construct Tk::Widget 'ConfigModelListViewer'; my @fbe1 = qw/-fill both -expand 1/; my @fxe1 = qw/-fill x -expand 1/; my @fx = qw/-fill x /; sub ClassInit { my ( $cw, $args ) = @_; # ClassInit is often used to define bindings and/or other # resources shared by all instances, e.g., images. # cw->Advertise(name=>$widget); } sub Populate { my ( $cw, $args ) = @_; my $list = $cw->{list} = delete $args->{-item} || die "ListViewer: no -item, got ", keys %$args; my $path = delete $args->{-path} || die "ListViewer: no -path, got ", keys %$args; my $cme_font = delete $args->{-font}; $cw->add_header( View => $list )->pack(@fx); my $inst = $list->instance; my $elt_frame = $cw->Frame(qw/-relief raised -borderwidth 2/)->pack(@fbe1); my $str = $list->element_name . ' ' . $list->get_type . ' elements'; $elt_frame->Label( -text => $str )->pack(); my $rt = $elt_frame->Scrolled( 'ROText', -height => 10, )->pack(@fbe1); my @insert = $list->cargo_type eq 'leaf' ? $list->fetch_all_values( check => 'no' ) : $list->fetch_all_indexes; foreach my $c (@insert) { my $line = defined $c ? $c : ''; $rt->insert( 'end', $line . "\n" ); } $cw->add_annotation($list)->pack(@fx); $cw->add_warning( $list, 'view' )->pack(@fx); $cw->add_summary($list)->pack(@fx); $cw->add_description($list)->pack(@fbe1); $cw->add_info_button()->pack( -side => 'left', @fxe1 ); $cw->add_editor_button($path)->pack( -side => 'right', @fxe1 ); $cw->ConfigSpecs(-font => [['SELF','DESCENDANTS'], 'font','Font', $cme_font ],); $cw->SUPER::Populate($args); } sub get_info { my $cw = shift; my $info_frame = shift; my $list = $cw->{list}; my @items = ( 'type : ' . $list->get_type, 'index : ' . $list->index_type, 'cargo : ' . $list->cargo_type, ); if ( $list->cargo_type eq 'node' ) { push @items, "cargo class: " . $list->config_class_name; } if ( $list->cargo_type eq 'leaf' ) { push @items, "leaf value type: " . ( $list->get_cargo_info('value_type') || '' ); } foreach my $what (qw/min_index max_index/) { my $v = $list->$what(); my $str = $what; $str =~ s/_/ /g; push @items, "$str: $v" if defined $v; } return $list->element_name, @items; } 1; Config-Model-TkUI-1.365/lib/Config/Model/Tk/LeafViewer.pm0000644000175000017500000001160213204357016021230 0ustar domidomi# # This file is part of Config-Model-TkUI # # This software is Copyright (c) 2008-2017 by Dominique Dumont. # # This is free software, licensed under: # # The GNU Lesser General Public License, Version 2.1, February 1999 # package Config::Model::Tk::LeafViewer; $Config::Model::Tk::LeafViewer::VERSION = '1.365'; use strict; use warnings; use 5.10.1; use Carp; use Log::Log4perl; use Text::Diff; use base qw/Tk::Frame Config::Model::Tk::AnyViewer/; Construct Tk::Widget 'ConfigModelLeafViewer'; my @fbe1 = qw/-fill both -expand 1/; my @fxe1 = qw/-fill x -expand 1/; my @fx = qw/-fill x /; my $logger = Log::Log4perl::get_logger("Tk::LeafViewer"); sub ClassInit { my ( $cw, $args ) = @_; # ClassInit is often used to define bindings and/or other # resources shared by all instances, e.g., images. # cw->Advertise(name=>$widget); } sub Populate { my ( $cw, $args ) = @_; my $leaf = $cw->{leaf} = delete $args->{-item} || die "LeafViewer: no -item, got ", keys %$args; my $path = delete $args->{-path} || die "LeafViewer: no -path, got ", keys %$args; my $cme_font = delete $args->{-font}; my $inst = $leaf->instance; my $vt = $leaf->value_type; $logger->info("Creating leaf viewer for value_type $vt"); my $v = $leaf->fetch( check => 'no' ); $cw->add_header( View => $leaf )->pack(@fx); my @pack_args = @fx; @pack_args = @fbe1 if $vt eq 'string'; my $lv_frame = $cw->Frame(qw/-relief raised -borderwidth 2/)->pack(@pack_args); $lv_frame->Label( -text => 'Value' )->pack(); if ( $vt eq 'string') { require Tk::ROText; $cw->{e_widget} = $lv_frame->Scrolled( 'ROText', -height => 5, -scrollbars => 'ow', )->pack(@fbe1); $cw->{e_widget}->insert( 'end', $v, 'value' ); $cw->{e_widget}->tagConfigure(qw/value -lmargin1 2 -lmargin2 2 -rmargin 2/); my $std = $cw->{leaf}->fetch_standard ; if ($std) { $lv_frame->Label( -text => 'Diff compared to standard value' )->pack(); $cw->{diff_widget} = $lv_frame->Scrolled( 'ROText', -height => 5, -scrollbars => 'ow', )->pack(@fbe1); # Text::Diff does not handle well files without trailing \n $std .= "\n" unless $std =~ /\n$/; my $new = $v // ''; $new .= "\n" unless $new =~ /\n$/; my $diff = diff( \$std, \$new , { STYLE => "Unified" } ); $cw->{diff_widget}->insert( 'end', $diff, 'value' ); $cw->{diff_widget}->tagConfigure(qw/value -lmargin1 2 -lmargin2 2 -rmargin 2/); } } else { my $v_frame = $lv_frame->Frame(qw/-relief sunken -borderwidth 1/)->pack(@fxe1); $v_frame->Label( -text => $v, -anchor => 'w' )->pack( @fxe1, -side => 'left' ); } $cw->add_annotation($leaf)->pack(@fx); $cw->add_summary($leaf)->pack(@fx); $cw->add_description($leaf)->pack(@fbe1); $cw->add_warning( $leaf, 'view' )->pack(@fx); $cw->add_help( 'value help' => $leaf->get_help( $cw->{value} ) )->pack(@fx); $cw->add_info_button()->pack( @fxe1, -side => 'left', -anchor => 'n' ); $cw->add_editor_button($path)->pack( @fxe1, -side => 'right', -anchor => 'n' ); $cw->ConfigSpecs( -font => [['SELF','DESCENDANTS'], 'font','Font', $cme_font ], #-fill => [ qw/SELF fill Fill both/], #-expand => [ qw/SELF expand Expand 1/], -relief => [qw/SELF relief Relief groove/], -borderwidth => [qw/SELF borderwidth Borderwidth 2/], DEFAULT => [qw/SELF/], ); $cw->SUPER::Populate($args); } sub get_info { my $cw = shift; my $leaf = $cw->{leaf}; my $type = $leaf->value_type; my @choice = $type eq 'enum' ? $leaf->get_choice : (); my $choice_str = @choice ? ' (' . join( ',', @choice ) . ')' : ''; my @items = ( 'type : ' . $leaf->value_type . $choice_str, ); my $std = $leaf->fetch(qw/mode standard check no/); if ( defined $leaf->upstream_default ) { push @items, "upstream_default value: " . $leaf->upstream_default; } elsif ( defined $std ) { push @items, "default value: $std"; } elsif ( defined $leaf->refer_to ) { push @items, "reference to: " . $leaf->refer_to; } elsif ( defined $leaf->computed_refer_to ) { push @items, "computed reference to: " . $leaf->computed_refer_to; } my $m = $leaf->mandatory; push @items, "is mandatory: " . ( $m ? 'yes' : 'no' ) if defined $m; foreach my $what (qw/min max warn grammar/) { my $v = $leaf->$what(); push @items, "$what value: $v" if defined $v; } foreach my $what (qw/warn_if_match warn_unless_match/) { my $v = $leaf->$what(); foreach my $k ( keys %$v ) { push @items, "$what value: $k"; } } return $leaf->element_name, @items; } 1; Config-Model-TkUI-1.365/lib/Config/Model/Tk/HashViewer.pm0000644000175000017500000000515513204357016021252 0ustar domidomi# # This file is part of Config-Model-TkUI # # This software is Copyright (c) 2008-2017 by Dominique Dumont. # # This is free software, licensed under: # # The GNU Lesser General Public License, Version 2.1, February 1999 # package Config::Model::Tk::HashViewer; $Config::Model::Tk::HashViewer::VERSION = '1.365'; use strict; use warnings; use Carp; use base qw/Tk::Frame Config::Model::Tk::AnyViewer/; use subs qw/menu_struct/; Construct Tk::Widget 'ConfigModelHashViewer'; my @fbe1 = qw/-fill both -expand 1/; my @fxe1 = qw/-fill x -expand 1/; my @fx = qw/-fill x /; sub ClassInit { my ( $cw, $args ) = @_; # ClassInit is often used to define bindings and/or other # resources shared by all instances, e.g., images. # cw->Advertise(name=>$widget); } sub Populate { my ( $cw, $args ) = @_; my $hash = $cw->{hash} = delete $args->{-item} || die "HashViewer: no -item, got ", keys %$args; my $path = delete $args->{-path} || die "HashViewer: no -path, got ", keys %$args; my $cme_font = delete $args->{-font}; $cw->add_header( View => $hash )->pack(@fx); my $inst = $hash->instance; my $elt_frame = $cw->Frame(qw/-relief raised -borderwidth 2/)->pack(@fbe1); my $str = $hash->element_name . ' ' . $hash->get_type . ' elements'; $elt_frame->Label( -text => $str )->pack(); my $rt = $elt_frame->Scrolled( 'ROText', -scrollbars => 'oe', -height => 10, )->pack(@fbe1); foreach my $c ( $hash->fetch_all_indexes ) { $rt->insert( 'end', $c . "\n" ); } $cw->add_annotation($hash)->pack(@fx); $cw->add_warning( $hash, 'view' )->pack(@fx); $cw->add_summary($hash)->pack(@fx); $cw->add_description($hash)->pack(@fbe1); $cw->add_info_button()->pack( -side => 'left', @fxe1 ); $cw->add_editor_button($path)->pack( -side => 'right', @fxe1 ); $cw->ConfigSpecs(-font => [['SELF','DESCENDANTS'], 'font','Font', $cme_font ],); $cw->SUPER::Populate($args); } sub get_info { my $cw = shift; my $hash = $cw->{hash}; my @items = ( 'type : ' . $hash->get_type . ( $hash->ordered ? '(ordered)' : '' ), 'index : ' . $hash->index_type, 'cargo : ' . $hash->cargo_type, ); if ( $hash->cargo_type eq 'node' ) { push @items, "cargo class: " . $hash->config_class_name; } foreach my $what (qw/min_index max_index max_nb warn_if_key_match warn_unless_key_match/) { my $v = $hash->$what(); my $str = $what; $str =~ s/_/ /g; push @items, "$str: $v" if defined $v; } return ( $hash->element_name, @items ); } 1; Config-Model-TkUI-1.365/lib/Config/Model/Tk/CheckListEditor.pm0000644000175000017500000001512413204357016022222 0ustar domidomi# # This file is part of Config-Model-TkUI # # This software is Copyright (c) 2008-2017 by Dominique Dumont. # # This is free software, licensed under: # # The GNU Lesser General Public License, Version 2.1, February 1999 # package Config::Model::Tk::CheckListEditor; $Config::Model::Tk::CheckListEditor::VERSION = '1.365'; use strict; use warnings; use Carp; use base qw/ Tk::Frame Config::Model::Tk::CheckListViewer/; use vars qw/$icon_path/; use subs qw/menu_struct/; use Tk::NoteBook; use Config::Model::Tk::NoteEditor; use Log::Log4perl; Construct Tk::Widget 'ConfigModelCheckListEditor'; my $up_img; my $down_img; my $logger = Log::Log4perl::get_logger("Tk::CheckListEditor"); *icon_path = *Config::Model::TkUI::icon_path; my @fbe1 = qw/-fill both -expand 1/; my @fxe1 = qw/-fill x -expand 1/; my @fx = qw/-fill x /; sub ClassInit { my ( $cw, $args ) = @_; # ClassInit is often used to define bindings and/or other # resources shared by all instances, e.g., images. # cw->Advertise(name=>$widget); } sub Populate { my ( $cw, $args ) = @_; my $leaf = $cw->{leaf} = delete $args->{-item} || die "CheckListEditor: no -item, got ", keys %$args; delete $args->{-path}; $cw->{store_cb} = delete $args->{-store_cb} || die __PACKAGE__, "no -store_cb"; my $cme_font = delete $args->{-font}; my $inst = $leaf->instance; $cw->add_header( Edit => $leaf )->pack(@fx); my $nb = $cw->Component( 'NoteBook', 'notebook' )->pack(@fbe1); my $lb; my @choice = $leaf->get_choice; my $raise_cmd = sub { $lb->selectionClear( 0, 'end' ); my %h = $leaf->get_checked_list_as_hash; for ( my $i = 0 ; $i < @choice ; $i++ ) { $lb->selectionSet( $i, $i ) if $h{ $choice[$i] }; } }; my $ed_frame = $nb->add( 'content', -label => 'Change content', -raisecmd => $raise_cmd, ); $lb = $ed_frame->Scrolled( qw/Listbox -selectmode multiple/, -scrollbars => 'osoe', -height => 5, )->pack(@fbe1); $lb->insert( 'end', @choice ); # mastering perl/Tk page 160 my $b_sub = sub { my @selected = map { $choice[$_] } $lb->curselection; $cw->set_value_help(@selected); }; $lb->bind( '<>', $b_sub ); my $bframe = $ed_frame->Frame->pack; $bframe->Button( -text => 'Clear all', -command => sub { $lb->selectionClear( 0, 'end' ); }, )->pack( -side => 'left' ); $bframe->Button( -text => 'Set all', -command => sub { $lb->selectionSet( 0, 'end' ); }, )->pack( -side => 'left' ); $bframe->Button( -text => 'Reset', -command => sub { $cw->reset_value; }, )->pack( -side => 'left' ); $bframe->Button( -text => 'Store', -command => sub { $cw->store() }, )->pack( -side => 'left' ); $cw->ConfigModelNoteEditor( -object => $leaf )->pack(@fbe1); $cw->add_summary($leaf)->pack(@fx); $cw->add_description($leaf)->pack(@fbe1); my ( $help_frame, $help_widget ) = $cw->add_help( value => '', 1 ); $help_frame->pack(@fx); $cw->{value_help_widget} = $help_widget; $cw->add_info_button()->pack(@fxe1); $b_sub->(); # Add a second page to edit the list order for ordered check list if ( $leaf->ordered ) { $cw->add_change_order_page( $nb, $leaf ); } $cw->Advertise( 'listbox' => $lb ); $cw->ConfigSpecs(-font => [['SELF','DESCENDANTS'], 'font','Font', $cme_font ],); # don't call directly SUPER::Populate as it's CheckListViewer's populate $cw->Tk::Frame::Populate($args); } sub add_change_order_page { my ( $cw, $nb, $leaf ) = @_; my $order_list; my $raise_cmd = sub { $order_list->delete( 0, 'end' ); $order_list->insert( end => $leaf->get_checked_list ); }; my $order_frame = $nb->add( 'order', -label => 'Change order', -raisecmd => $raise_cmd, ); $order_list = $order_frame->Scrolled( 'Listbox', -selectmode => 'single', -scrollbars => 'oe', -height => 6, )->pack(@fbe1); $cw->{order_list} = $order_list; unless ( defined $up_img ) { $up_img = $cw->Photo( -file => $icon_path . 'up.png' ); $down_img = $cw->Photo( -file => $icon_path . 'down.png' ); } my $mv_up_down_frame = $order_frame->Frame->pack( -fill => 'x' ); $mv_up_down_frame->Button( -image => $up_img, -command => sub { $cw->move_selected_up; }, )->pack( -side => 'left', @fxe1 ); $mv_up_down_frame->Button( -image => $down_img, -command => sub { $cw->move_selected_down; }, )->pack( -side => 'left', @fxe1 ); } sub move_selected_up { my $cw = shift; my $order_list = $cw->{order_list}; my @idx = $order_list->curselection(); return unless @idx and $idx[0] > 0; my $name = $order_list->get(@idx); $order_list->delete(@idx); my $new_idx = $idx[0] - 1; $order_list->insert( $new_idx, $name ); $order_list->selectionSet($new_idx); $order_list->see($new_idx); $cw->{leaf}->move_up($name); $cw->{store_cb}->(); } sub move_selected_down { my $cw = shift; my $order_list = $cw->{order_list}; my @idx = $order_list->curselection(); my $leaf = $cw->{leaf}; my @h_idx = $leaf->get_checked_list; return unless @idx and $idx[0] < $#h_idx; my $name = $order_list->get(@idx); $logger->debug("move_selected_down: $name (@idx)"); $order_list->delete(@idx); my $new_idx = $idx[0] + 1; $order_list->insert( $new_idx, $name ); $order_list->selectionSet($new_idx); $order_list->see($new_idx); $cw->{leaf}->move_down($name); $cw->{store_cb}->(); } sub store { my $cw = shift; my $lb = $cw->Subwidget('listbox'); my @choice = $cw->{leaf}->get_choice; my %set = map { $_ => 1; } map { $choice[$_] } $lb->curselection; my $cl = $cw->{leaf}; map { if ( $set{$_} and not $cl->is_checked($_) ) { $cl->check($_); } elsif ( not $set{$_} and $cl->is_checked($_) ) { $cl->uncheck($_); } } @choice; $cw->{store_cb}->(); } sub reset_value { my $cw = shift; my $h_ref = $cw->{leaf}->get_checked_list_as_hash; # reset also the content of the listbox # weird behavior of tied Listbox :-/ ${ $cw->{tied} } = $cw->{leaf}->get_checked_list; # the CheckButtons have stored the reference of the hash *values* # so we must preserve them. map { $cw->{check_list}{$_} = $h_ref->{$_} } keys %$h_ref; $cw->{help} = ''; } 1; Config-Model-TkUI-1.365/lib/Config/Model/Tk/AnyViewer.pm0000644000175000017500000001714513204357016021120 0ustar domidomi# # This file is part of Config-Model-TkUI # # This software is Copyright (c) 2008-2017 by Dominique Dumont. # # This is free software, licensed under: # # The GNU Lesser General Public License, Version 2.1, February 1999 # package Config::Model::Tk::AnyViewer; $Config::Model::Tk::AnyViewer::VERSION = '1.365'; use strict; use warnings; use Carp; use Tk::Photo; use Tk::ROText; use Tk::Dialog; use Config::Model::TkUI; use Log::Log4perl qw(get_logger :levels); use Tk::Pod::Text; use vars qw/$icon_path/; my $logger = get_logger("Tk"); my @fbe1 = qw/-fill both -expand 1/; my @fxe1 = qw/-fill x -expand 1/; my @fb = qw/-fill both /; my @fx = qw/-fill x /; my @e1 = qw/ -expand 1/; my %img; *icon_path = *Config::Model::TkUI::icon_path; sub add_header { my ( $cw, $type, $item ) = @_; unless (%img) { $img{edit} = $cw->Photo( -file => $icon_path . 'wizard.png' ); $img{view} = $cw->Photo( -file => $icon_path . 'viewmag.png' ); } my $idx; $idx = $item->index_value if $item->can('index_value'); my $elt_name = $item->composite_name; my $parent = $item->parent; my $class = defined $parent ? $item->parent->config_class_name : $item->config_class_name; $cw->{config_class_name} = $class; my $label = "$type: "; $label .= $item->location_short || "Class $class"; my $f = $cw->Frame; $f->Label( -image => $img{ lc($type) }, -anchor => 'w' )->pack( -side => 'left' ); $f->Label( -text => $label, -anchor => 'e' )->pack( -side => 'left', @fx ); return $f; } my @top_frame_args = qw/-relief raised -borderwidth 4/; my @low_frame_args = qw/-relief sunken -borderwidth 1/; my $padx = 20; sub add_info_button { my $cw = shift; my $frame = shift || $cw; my ( $elt_name, @items ) = $cw->get_info; my $title = "Info on " . $cw->{config_class_name}; $title .= ':' . $elt_name if $elt_name; my $dialog = $cw->Dialog( -title => $title, -text => join( "\n", $title, @items ), ); my $button = $frame->Button( -text => "info ...", -command => sub { $dialog->Show; } ); return $button; # to be packed by caller } # returns the help widget (Label or ROText) which must be packed by caller sub add_help { my $cw = shift; my $help_label = shift; my $help = shift || ''; my $force_text_widget = shift || ''; # pod or text my $help_frame = $cw->Frame(); return $help_frame unless $force_text_widget or $help; $help_frame->Label( -text => $help_label, )->pack( -anchor => 'w' ); my $widget; chomp $help; # if ( $force_text_widget eq 'pod' or $help =~ /\n=\w+|[A-Z] 50 ) { $widget = $help_frame->PodText( -height => 6, -scrollbars => 'oe' ); $widget->base_font_size(12); $widget->pack(@fbe1); $cw->update_help( $widget, $help ); } # elsif ($force_text_widget or $help =~ /\n/ or length($help) > 50) { # $widget = $help_frame->Scrolled('ROText', # -scrollbars => 'ow', # -wrap => 'word', # -font => $text_font , # -relief => 'ridge', # -height => 4, # ); # # $widget ->pack( @fbe1 ) ->insert('end',$help,'help') ; # $widget # ->tagConfigure(qw/help -lmargin1 2 -lmargin2 2 -rmargin 2/); # } elsif ( $help =~ /\w/ ) { $widget = $help_frame->Label( -text => $help, -justify => 'left', -anchor => 'w', -padx => $padx, )->pack( -fill => 'x' ); } return wantarray ? ( $help_frame, $widget ) : $help_frame; } sub update_help { my ( $cw, $w, $help ) = @_; # work around RT #67306 my $t = $cw->toplevel->cget('-title'); $w->text("\n\n=pod\n\n\n=encoding utf8\n\n$help\n\n=cut\n\n"); $w->toplevel->title($t); } sub add_summary { my ( $cw, $elt_obj ) = @_; my $p = $elt_obj->parent; my $name = $elt_obj->element_name; return $cw->add_help( Summary => $p->get_help( summary => $name ) ); } sub add_description { my ( $cw, $elt_obj ) = @_; my $p = $elt_obj->parent; my $name = $elt_obj->element_name; return $cw->add_help( Description => $p->get_help( description => $name ) ); } sub add_warning { my ( $cw, $elt_obj, $usage ) = @_; my $frame = $cw->Frame; # packed by caller my $inner_frame = $frame->Frame; # packed by update_warning my $label_button_frame = $inner_frame->Frame->pack(@fxe1); $label_button_frame->Label( -text => 'Issues', ) ->pack( -anchor => 'w', -side => 'left', -fill => 'x' ); if ( $usage eq 'edit' ) { my $nb_fixes = $elt_obj->has_fixes || 0; my $fix_widget = $label_button_frame->Button( -text => "Apply $nb_fixes fixes", -state => $nb_fixes ? 'normal' : 'disabled' ); $fix_widget->pack( -anchor => 'e', -side => 'right' ); $cw->Advertise( fix_widget => $fix_widget ); } my $warn_widget = $inner_frame->Scrolled( 'ROText', -scrollbars => 'ow', -wrap => 'word', -relief => 'ridge', -height => 4, ); my $err = $elt_obj->error_msg || ''; $warn_widget->pack(@fbe1)->insert( 'end', $err, 'error' ); $warn_widget->tagConfigure(qw/error -lmargin1 2 -lmargin2 2 -rmargin 2 -background red/); my $msg = $elt_obj->warning_msg || ''; $msg .= "with " . $elt_obj->has_fixes . " fixes" if $msg; $warn_widget->pack(@fbe1)->insert( 'end', $msg, 'warning' ); $warn_widget->tagConfigure(qw/warning -lmargin1 2 -lmargin2 2 -rmargin 2 -background orange/); $logger->debug( "creating warning widget" . ( $err ? " with errors" : '' ) . ( $msg ? " with warnings" : '' ) ); $cw->Advertise( warn_widget => $warn_widget ); $cw->Advertise( warn_frame => $inner_frame ); $cw->update_warning($elt_obj); return $frame; } sub update_warning { my ( $cw, $elt_obj ) = @_; my $wf = $cw->Subwidget('warn_frame'); my $ww = $cw->Subwidget('warn_widget'); my $fw = $cw->Subwidget('fix_widget'); $ww->delete( '0.0', 'end' ); $elt_obj->check; my $err = $elt_obj->error_msg || ''; $ww->insert( 'end', $err, 'error' ) if $err; my $msg .= $elt_obj->warning_msg || ''; if ( ref($msg) eq 'HASH' ) { $msg = join( '', map { join( "\n\t", @{ $msg->{$_} } ) } sort keys %$msg ); } $ww->insert( 'end', $msg, 'warning' ) if $msg; $logger->debug( "updating warning widget" . ( $err ? " with errors" : '' ) . ( $msg ? " with warnings" : '' ) ); if ( $msg or $err ) { $wf->pack(@fbe1); if ( $msg and defined $fw ) { my $nb_fixes = $elt_obj->has_fixes; $fw->configure( -text => "Apply $nb_fixes fixes", -command => sub { $elt_obj->apply_fixes; $cw->reset_value; $cw->update_warning($elt_obj); $cw->{store_cb}->(); }, -state => $nb_fixes ? 'normal' : 'disabled' ); } } else { $wf->packForget; } } # returns a widget that must be packed sub add_annotation { my ( $cw, $obj ) = @_; return $cw->add_help( 'Note', $obj->annotation ); } sub add_editor_button { my ( $cw, $path ) = @_; my $sub = sub { $cw->parent->parent->parent->parent->create_element_widget( edit => $path ); }; return $cw->Button( -text => 'Edit ...', -command => $sub ); } # do nothing by default sub reload { } 1; Config-Model-TkUI-1.365/lib/Config/Model/Tk/NodeEditor.pm0000644000175000017500000001537413204357016021245 0ustar domidomi# # This file is part of Config-Model-TkUI # # This software is Copyright (c) 2008-2017 by Dominique Dumont. # # This is free software, licensed under: # # The GNU Lesser General Public License, Version 2.1, February 1999 # package Config::Model::Tk::NodeEditor; $Config::Model::Tk::NodeEditor::VERSION = '1.365'; use strict; use warnings; use Carp; use Tk::Pane; use Tk::Balloon; use Text::Wrap; use Config::Model::Tk::NoteEditor; use base qw/Config::Model::Tk::NodeViewer/; use subs qw/menu_struct/; Construct Tk::Widget 'ConfigModelNodeEditor'; my @fbe1 = qw/-fill both -expand 1/; my @fxe1 = qw/-fill x -expand 1/; my @fx = qw/-fill x -expand 0/; my $logger = Log::Log4perl::get_logger("Tk::NodeEditor"); sub ClassInit { my ( $cw, $args ) = @_; # ClassInit is often used to define bindings and/or other # resources shared by all instances, e.g., images. # cw->Advertise(name=>$widget); } sub Populate { my ( $cw, $args ) = @_; my $node = $cw->{node} = delete $args->{-item} || die "NodeViewer: no -item, got ", keys %$args; $cw->{path} = delete $args->{-path}; $cw->{store_cb} = delete $args->{-store_cb} || die __PACKAGE__, "no -store_cb"; my $cme_font = $cw->{my_font} = delete $args->{-font}; $cw->add_header( Edit => $node )->pack(@fx); $cw->Label( -text => $node->composite_name . ' node elements' )->pack(); $cw->{pane} = $cw->Scrolled(qw/Pane -scrollbars osow -sticky senw/); $cw->{pane}->pack(@fbe1); $cw->fill_pane; # insert a widget for "accepted" elements my @rexp = $node->accept_regexp; if (@rexp) { $cw->add_accept_entry(@rexp); } # add adjuster #require Tk::Adjuster; #$cw -> Adjuster()->pack(-fill => 'x' , -side => 'top') ; $cw->ConfigModelNoteEditor( -object => $node )->pack; $cw->add_info_button()->pack( @fxe1, qw/-anchor n/ ); if ( $node->parent ) { $cw->add_summary($node)->pack(@fx); $cw->add_description($node)->pack(@fbe1); } else { $cw->add_help( class => $node->get_help )->pack(@fx); } $cw->ConfigSpecs(-font => [['SELF','DESCENDANTS'], 'font','Font', $cme_font ],); # don't call directly SUPER::Populate as it's NodeViewer's populate $cw->Tk::Frame::Populate($args); # TODO: above is a hack. The required methods of NodeViewer and # AnyViewer should be moved into a role. Question: how can roles # be done with Tk ?? } sub reload { goto &fill_pane; } sub fill_pane { my $cw = shift; my $node = $cw->{node}; my $elt_pane = $cw->{pane}; my %is_elt_drawn = map { ( $_ => 1 ) } keys %{ $cw->{elt_widgets} || {} }; my %values; my %modified; my $prev_elt; my $font = $cw->{my_font}; #cget('-font'); foreach my $c ( $node->get_element_name() ) { if ( delete $is_elt_drawn{$c} ) { $prev_elt = $c; next; } my $type = $node->element_type($c); my $elt_path = $cw->{path} . '.' . $c; my @after = defined $prev_elt ? ( -after => $cw->{elt_widgets}{$prev_elt} ) : (); $prev_elt = $c; my $f = $elt_pane->Frame( -relief => 'groove', -borderwidth => 1 ); $f->pack( -side => 'top', @fx, @after ); $cw->{elt_widgets}{$c} = $f; my $label = $f->Label( -text => $c, -font => $font, -width => 22, -anchor => 'w' ); $label->pack(qw/-side left -fill x -anchor w/); my $help = $node->get_help_as_text( summary => $c ) || $node->get_help_as_text( description => $c ); $cw->Balloon( -state => 'balloon' )->attach( $label, -msg => wrap( '', '', $help ) ); if ( $type eq 'leaf' ) { my $leaf = $node->fetch_element($c); my $v = $node->fetch_element_value( name => $c, check => 'no' ); my $store_sub = sub { $leaf->store($v); $cw->{store_cb}->($elt_path); $cw->fill_pane; }; my $v_type = $leaf->value_type; if ( $v_type =~ /integer|number|uniline/ ) { my $e = $f->Entry( -textvariable => \$v )->pack( qw/-side left -anchor w/, @fxe1 ); $e->bind( "" => $store_sub ); $e->bind( "" => $store_sub ); next; } if ( $v_type =~ /boolean/ ) { my $e = $f->Checkbutton( -variable => \$v, -font => $font, -command => $store_sub ) ->pack(qw/-side left -anchor w/); next; } if ( $v_type =~ /enum|reference/ ) { my @choices = $leaf->get_choice; require Tk::BrowseEntry; my $e = $f->BrowseEntry( -variable => \$v, -font => $font, -browsecmd => $store_sub, -choices => \@choices )->pack( qw/-side left -anchor w/, @fxe1 ); next; } } # add button to launch dedicated editor my $obj = $node->fetch_element($c); my $edit_sub = sub { # it would be better for tkui ui to pass this as a callback # note that storing tkui object in a sub widget creates issues with tk $cw->parent->parent->parent->parent->create_element_widget( 'edit', $elt_path, $obj ); }; my $edb = $f->Button( -text => '...', -font => $font, -command => $edit_sub ); $edb->pack( -anchor => 'w' ); my $content = $type eq 'leaf' ? $obj->fetch( check => 'no' ) || '' : $type eq 'node' ? $node->config_class_name : $type; $cw->Balloon( -state => 'balloon' )->attach( $edb, -msg => wrap( '', '', $content ) ); } # destroy leftover widgets (may occur with warp mechanism) map { my $w = delete $cw->{elt_widgets}{$_}; $w->destroy } keys %is_elt_drawn; } sub add_accept_entry { my ( $cw, @rexp ) = @_; my $node = $cw->{node}; my $f = $cw->Frame( -relief => 'groove', -borderwidth => 1 ); $f->pack( -side => 'top', @fx ); my $font = $cw->{my_font}; #cget('-font'); my $accepted = ''; $f->Label( -text => 'accept : /' . join( '/, /', @rexp ) . '/', -font => $font )->pack; my $e = $f->Entry( -textvariable => \$accepted, -font => $font)->pack( qw/-side left -anchor w/, @fxe1 ); my $sub = sub { return unless $accepted; my $ok = 0; map { $ok++ if $accepted =~ /^$_$/ } @rexp; if ( not $ok ) { die "Cannot accept $accepted, it does not match any accepted regexp\n"; } $node->fetch_element($accepted); $cw->{store_cb}->(); $cw->fill_pane; $cw->{pane}->yview( moveto => 1 ); }; $e->bind( "" => $sub ); } 1; Config-Model-TkUI-1.365/lib/Config/Model/Tk/LeafEditor.pm0000644000175000017500000002563513204357016021230 0ustar domidomi# # This file is part of Config-Model-TkUI # # This software is Copyright (c) 2008-2017 by Dominique Dumont. # # This is free software, licensed under: # # The GNU Lesser General Public License, Version 2.1, February 1999 # package Config::Model::Tk::LeafEditor; $Config::Model::Tk::LeafEditor::VERSION = '1.365'; use strict; use warnings; use Carp; use Log::Log4perl; use Config::Model::Tk::NoteEditor; use Path::Tiny; use Tk::Balloon; use base qw/Config::Model::Tk::LeafViewer/; Construct Tk::Widget 'ConfigModelLeafEditor'; my @fbe1 = qw/-fill both -expand 1/; my @fxe1 = qw/-fill x -expand 1/; my @fx = qw/-fill x /; my $logger = Log::Log4perl::get_logger("Tk::LeafEditor"); sub ClassInit { my ( $cw, $args ) = @_; # ClassInit is often used to define bindings and/or other # resources shared by all instances, e.g., images. # cw->Advertise(name=>$widget); } sub Populate { my ( $cw, $args ) = @_; my $leaf = $cw->{leaf} = delete $args->{-item} || die "LeafEditor: no -item, got ", keys %$args; delete $args->{-path}; $cw->{store_cb} = delete $args->{-store_cb} || die __PACKAGE__, "no -store_cb"; my $cme_font = delete $args->{-font}; my $inst = $leaf->instance; my $vt = $leaf->value_type; $logger->info("Creating leaf editor for value_type $vt"); $cw->{value} = $leaf->fetch( check => 'no', mode => 'user' ); $logger->info( "Creating leaf editor with error " . $leaf->error_msg ); $cw->add_header( Edit => $leaf )->pack(@fx); my $vref = \$cw->{value}; my @pack_args = @fx; @pack_args = @fbe1 if $vt eq 'string' or $vt eq 'enum' or $vt eq 'reference'; my $ed_frame = $cw->Frame(qw/-relief raised -borderwidth 2/)->pack(@pack_args); $ed_frame->Label( -text => 'Edit value' )->pack(); my $balloon = $cw->Balloon( -state => 'balloon' ); if ( $vt eq 'string' ) { $cw->{e_widget} = $ed_frame->Scrolled( 'Text', -height => 5, -scrollbars => 'ow', )->pack(@fbe1); $cw->{e_widget}->tagConfigure(qw/value -lmargin1 2 -lmargin2 2 -rmargin 2/); $cw->reset_value; my $bframe = $cw->add_buttons($ed_frame); $bframe->Button( -text => 'Cleanup', -command => sub { $cw->cleanup }, )->pack( -side => 'left' ); my $ext_ed_b = $bframe->Button( -text => 'Ext editor', -command => sub { $cw->exec_external_editor }, -state => defined $ENV{EDITOR} ? 'normal' : 'disabled', )->pack( -side => 'left' ); $balloon->attach( $ext_ed_b, -msg => "Run external editor (if EDITOR environment variable is set" ); } elsif ( $vt eq 'boolean' ) { $ed_frame->Checkbutton( -text => $leaf->element_name, -variable => $vref, -command => sub { $cw->try }, )->pack(); $cw->add_buttons($ed_frame); } elsif ( $vt eq 'uniline' or $vt eq 'integer' ) { $ed_frame->Entry( -textvariable => $vref )->pack(@fx); $cw->add_buttons($ed_frame); } elsif ( $vt eq 'enum' or $vt eq 'reference' ) { my $lb = $ed_frame->Scrolled( 'Listbox', -height => 5, -scrollbars => 'osow', #-listvariable => $vref, #-selectmode => 'single', )->pack(@fbe1); my @choice = $leaf->get_choice; $lb->insert( 'end', $leaf->get_choice ); my $idx = 0; if ( defined $$vref ) { map { $lb->selectionSet($idx) if $_ eq $$vref; $idx++ } @choice; } $lb->bind( '', sub { $cw->try( $lb->get( $lb->curselection() ) ) } ); $cw->add_buttons($ed_frame); } $cw->ConfigModelNoteEditor( -object => $leaf )->pack; $cw->add_warning( $leaf, 'edit' )->pack(@fx); $cw->add_info_button()->pack( @fx, qw/-anchor n/ ); $cw->add_summary($leaf)->pack(@fx); $cw->add_description($leaf)->pack(@fbe1); my ( $help_frame, $help_widget ) = $cw->add_help( 'help on value' => '', 1 ); $help_frame->pack(@fx); $cw->Advertise( value_help_widget => $help_widget ); $cw->Advertise( value_help_frame => $help_frame ); $cw->set_value_help; $cw->ConfigSpecs( -font => [['SELF','DESCENDANTS'], 'font','Font', $cme_font ], #-fill => [ qw/SELF fill Fill both/], #-expand => [ qw/SELF expand Expand 1/], -relief => [qw/SELF relief Relief groove/], -borderwidth => [qw/SELF borderwidth Borderwidth 2/], DEFAULT => [qw/SELF/], ); # don't call directly SUPER::Populate as it's LeafViewer's populate $cw->Tk::Frame::Populate($args); } sub cleanup { my ($cw) = @_; my $text_widget = $cw->{e_widget} || return; my $selected = $text_widget->getSelected; my $text = $selected || $text_widget->Contents; $text =~ s/^\s+//gm; $text =~ s/\s+$//gm; $text =~ s/\s+/ /g; if ($selected) { $text_widget->Insert($text); } else { $text_widget->Contents($text); } } sub add_buttons { my ( $cw, $frame ) = @_; my $bframe = $frame->Frame->pack(); my $balloon = $cw->Balloon( -state => 'balloon' ); my $reset_b = $bframe->Button( -text => 'Reset', -command => sub { $cw->reset_value; }, )->pack( -side => 'left' ); $balloon->attach( $reset_b, -msg => "reset entry value from tree value" ); my $del_label = defined $cw->{leaf}->fetch_standard ? 'Back to default' : 'Delete'; $bframe->Button( -text => $del_label, -command => sub { $cw->delete }, )->pack( -side => 'left' ); my $store_b = $bframe->Button( -text => 'Store', -command => sub { $cw->store }, )->pack( -side => 'right' ); $balloon->attach( $store_b, -msg => "store entry value in config tree" ); return $bframe; } sub try { my $cw = shift; my $v = shift; if ( defined $v ) { $cw->{value} = $v; } else { my $e_w = $cw->{e_widget}; # tk widget use a reference $v = defined $e_w ? $e_w->get( '1.0', 'end' ) : $cw->{value}; } $v = '' unless defined $v; chomp $v; $logger->debug("try: value $v"); require Tk::Dialog; my @errors = $cw->{leaf}->check( value => $v, quiet => 1 ); if (@errors) { $cw->Dialog( -title => 'Value error', -text => join( "\n", @errors ), -font => scalar $cw->cget('-font'), )->Show; $cw->reset_value; return; } else { $cw->set_value_help($v); return $v; } } sub delete { my $cw = shift; eval { $cw->{leaf}->store(undef); }; if ($@) { $cw->Dialog( -title => 'Delete error', -text => ref($@) ? $@->as_string : $@, )->Show; } else { # trigger redraw of Tk Tree $cw->reset_value; $cw->update_warning( $cw->{leaf} ); $cw->{store_cb}->(); } } # can be used without parameters to store value from widget into config tree sub store { my $cw = shift; my $arg = shift; my $e_w = $cw->{e_widget}; # tk widget use a reference my $v = defined $arg ? $arg : defined $e_w ? $e_w->get( '1.0', 'end' ) : $cw->{value}; $v = '' unless defined $v; chomp $v; print "Storing '$v'\n"; my $leaf = $cw->{leaf}; eval { $leaf->store($v); }; if ($@) { $cw->Dialog ( -title => 'Value error', -text => $@->as_string, -font => scalar $cw->cget('-font'), )->Show; $cw->reset_value; } elsif ($leaf->has_error) { $cw->Dialog ( -title => 'Value error', -text => "Cannot store the value:\n* ".join("\n* ",$leaf->all_errors), -font => scalar $cw->cget('-font'), )->Show; $cw->reset_value; } else { # trigger redraw of Tk Tree $cw->{store_cb}->(); $cw->update_warning( $leaf ); } } sub set_value_help { my $cw = shift; my $v = $cw->{value}; my $value_help = defined $v ? $cw->{leaf}->get_help($v) : ''; my $w = $cw->Subwidget('value_help_widget'); my $f = $cw->Subwidget('value_help_frame'); if ($value_help) { #$w->delete( '0.0', 'end' ); #$w->insert( 'end', $value_help ) ; $cw->update_help( $w, $value_help ); $f->pack(@fbe1); } else { $f->packForget; } } sub reset_value { my $cw = shift; $cw->{value} = $cw->{leaf}->fetch( check => 'no' ); if ( defined $cw->{e_widget} ) { $cw->{e_widget}->delete( '1.0', 'end' ); $cw->{e_widget}->insert( 'end', $cw->{value}, 'value' ); } $cw->set_value_help if defined $cw->{value_help_widget}; } sub exec_external_editor { my $cw = shift; my @pt_args; # ugly hack to use pod mode only for Model description parameter # i.e. for 'cme meta edit; my $leaf = $cw->{leaf}; if ($leaf->parent->config_class_name =~ /^Itself/ and $leaf->element_name =~ /description/ ) { # the .pod suffix let the editor use the correct mode @pt_args = (SUFFIX => '.pod'); } my $pt = Path::Tiny->tempfile(@pt_args); die "Can't create Path::Tiny:$!" unless defined $pt; $pt->spew_utf8( $cw->{e_widget}->get( '1.0', 'end' ) ); # See mastering Perl/Tk p382 my $h = $cw->{ed_handle} = IO::Handle->new; die "IO::Handle->new failed." unless defined $h; my $ed = $ENV{EDITOR} . ' ' . $pt->canonpath; $cw->{ed_pid} = open $h, $ed . ' 2>&1 |'; if ( not defined $cw->{ed_pid} ) { $cw->Dialog( -title => 'External editor error', -text => "'$ed' : $!", -font => scalar $cw->cget('-font'), )->Show; return; } $h->autoflush(1); $cw->fileevent( $h, 'readable' => [ \&_read_stdout, $cw ] ); # prevent navigation in the tree (and destruction of this widget # while the external editor is active). See mastering Perl/Tk p302 $cw->grab; $cw->waitVariable( \$cw->{ed_done} ); $cw->grabRelease; my $new_v = $pt->slurp_utf8(); print "exec_external_editor done with '$new_v'\n"; $cw->store($new_v); $cw->reset_value; } # also from Mastering Perl/Tk sub _read_stdout { # Called when input is available for the output window. Also checks # to see if the user has clicked Cancel. print "_read_stdout called\n"; my ($cw) = @_; my $h = $cw->{ed_handle}; die "External editor handle is udefined!\n" unless defined $h; my $stat; if ( $stat = sysread $h, $_, 4096 ) { print; } elsif ( $stat == 0 ) { print "edition done\n"; $h->close; $cw->{ed_done} = 1; } else { die "External editor sysread error: $!"; } } # end _read_stdout sub reload { my $cw = shift; $cw->reset_value; $cw->update_warning( $cw->{leaf} ); } 1; Config-Model-TkUI-1.365/lib/Config/Model/Tk/HashEditor.pm0000644000175000017500000003757413204357016021251 0ustar domidomi# # This file is part of Config-Model-TkUI # # This software is Copyright (c) 2008-2017 by Dominique Dumont. # # This is free software, licensed under: # # The GNU Lesser General Public License, Version 2.1, February 1999 # package Config::Model::Tk::HashEditor; $Config::Model::Tk::HashEditor::VERSION = '1.365'; use strict; use warnings; use Carp; use Log::Log4perl; use base qw/Config::Model::Tk::HashViewer/; use vars qw/$icon_path/; use subs qw/menu_struct/; use Tk::Dialog; use Tk::Photo; use Tk::Balloon; use Config::Model::Tk::NoteEditor; Construct Tk::Widget 'ConfigModelHashEditor'; my @fbe1 = qw/-fill both -expand 1/; my @fxe1 = qw/-fill x -expand 1/; my @fx = qw/-fill x /; my $logger = Log::Log4perl::get_logger("Tk::HashEditor"); my $entry_width = 15; my ( $up_img, $down_img, $add_img, $rm_img, $eraser_img, $remove_img, $rename_img, $copy_img ); *icon_path = *Config::Model::TkUI::icon_path; sub ClassInit { my ( $cw, $args ) = @_; # ClassInit is often used to define bindings and/or other # resources shared by all instances, e.g., images. # cw->Advertise(name=>$widget); } # list of widget that must be activated (0 in this table) when # item is selected in listbox or entry is not empty my %widget_activation_table = ( add => { tklist => 1, entry => 0 }, mv => { tklist => 0, entry => 0 }, cp => { tklist => 0, entry => 0 }, up => { tklist => 0, entry => 1 }, down => { tklist => 0, entry => 1 }, del => { tklist => 0, entry => 1 }, ); sub Populate { my ( $cw, $args ) = @_; my $hash = $cw->{hash} = delete $args->{-item} || die "HashEditor: no -item, got ", keys %$args; delete $args->{-path}; $cw->{store_cb} = delete $args->{-store_cb} || die __PACKAGE__, "no -store_cb"; my $cme_font = delete $args->{-font}; unless ( defined $up_img ) { $add_img = $cw->Photo( -file => $icon_path . 'add.png' ); $up_img = $cw->Photo( -file => $icon_path . 'up.png' ); $down_img = $cw->Photo( -file => $icon_path . 'down.png' ); $eraser_img = $cw->Photo( -file => $icon_path . 'eraser.png' ); $remove_img = $cw->Photo( -file => $icon_path . 'remove.png' ); $rename_img = $cw->Photo( -file => $icon_path . 'rotate_cw.png' ); $copy_img = $cw->Photo( -file => $icon_path . 'fontsizeup.png' ); } $cw->add_header( Edit => $hash )->pack( @fx, -anchor => 'n' ); my $inst = $hash->instance; # frame for element list my $elt_frame = $cw->Frame(qw/-relief raised -borderwidth 2/)->pack(@fbe1); $elt_frame->Label( -text => $hash->element_name . ' elements' )->pack(@fx); # element list my $tklist = $elt_frame->Scrolled( 'Listbox', -selectmode => 'single', -scrollbars => 'oe', -height => 6, ); $tklist->pack( @fbe1, -side => 'left' ); $cw->Advertise( tklist => $tklist ); $cw->reset_value; my $item_frame = $cw->Frame(qw/-borderwidth 1 -relief groove/)->pack( @fx, -anchor => 'n' ); my $balloon = $cw->Balloon( -state => 'balloon' ); my $label_keep_frame = $item_frame->Frame->pack(@fxe1); my $item = ''; my $keep = 0; $label_keep_frame->Label( -text => 'Item:' )->pack( -side => 'left', -anchor => 'w' ); # clear entry my $clear_b = $label_keep_frame->Button( -command => sub { $item = ''; }, -text => 'clear' )->pack(qw/-side right -anchor e/); $balloon->attach( $clear_b, -msg => 'clear entry below' ); # copy select entry my $copy_cb = sub { my $sel = $tklist->curselection; $item = $tklist->get($sel) if $sel; }; my $copy_b = $label_keep_frame->Button( -command => $copy_cb, -text => 'copy' )->pack(qw/-side right -anchor e/); $balloon->attach( $copy_b, -msg => 'copy selected item in entry below' ); my $keep_b = $label_keep_frame->Checkbutton( -variable => \$keep, -text => 'keep' )->pack(qw/-side right -anchor e/); $balloon->attach( $keep_b, -msg => 'keep content of entry below after add, move or copy' ); # Entry my $entry = $item_frame->Entry( -textvariable => \$item ); $entry->pack( @fxe1, qw/-side top -anchor n/ ); $balloon->attach( $entry, -msg => 'enter item name to add, copy to, or move to' ); $cw->Advertise( entry => $entry ); # bind both entries to update correctly the state of all buttons my $bound_sub = sub { $cw->update_state( entry => $item, tklist => $tklist->curselection || 0 ); }; $entry->bind( '', $bound_sub ); $entry->bind( '', $bound_sub ); $tklist->bind( '<>', $bound_sub ); # frame for all buttons my $button_frame = $item_frame->Frame->pack( @fxe1, qw/-anchor n/ ); # add button my $addb = $button_frame->Button( -image => $add_img, -command => sub { $cw->add_entry($item); $item = '' unless $keep; &$bound_sub; }, ); $addb->pack( @fxe1, qw/-side left/ ); $cw->Advertise( add => $addb ); my $add_str = $hash->ordered ? " after selection" : ''; $balloon->attach( $addb, -msg => "fill field above and click to add new entry" . $add_str ); # copy button my $cp_b = $button_frame->Button( -image => $copy_img, -command => sub { $cw->copy_selected_in($item); $item = '' unless $keep; &$bound_sub; }, ); $cp_b->pack( @fxe1, qw/-side right/ ); $cw->Advertise( @fxe1, cp => $cp_b ); $balloon->attach( $cp_b, -msg => "copy selected item in entry" ); # rename button my $rename_b = $button_frame->Button( -image => $rename_img, -command => sub { $cw->move_selected_to($item); $item = '' unless $keep; &$bound_sub,; }, ); $rename_b->pack( @fxe1, -side => 'left' ); $cw->Advertise( mv => $rename_b ); $balloon->attach( $rename_b, -msg => "rename selected key in entry" ); if ( $hash->ordered ) { my $up_b = $button_frame->Button( -image => $up_img, -command => sub { $cw->move_selected_up; }, ); my $down_b = $button_frame->Button( -image => $down_img, -command => sub { $cw->move_selected_down; }, ); $up_b->pack( -side => 'left', @fxe1 ); $down_b->pack( -side => 'left', @fxe1 ); $cw->Advertise( up => $up_b ); $cw->Advertise( down => $down_b ); } my $eraser_b = $button_frame->Button( -image => $eraser_img, -command => sub { $cw->delete_selection; $item = '' unless $keep; &$bound_sub; }, ); $balloon->attach( $eraser_b, -msg => 'Remove selected key' ); $eraser_b->pack( -side => 'left', @fxe1 ); $cw->Advertise( del => $eraser_b ); my $rm_all_b = $button_frame->Button( -image => $remove_img, -command => sub { $cw->remove_all_elements; $item = ''; }, )->pack( -side => 'left', @fxe1 ); $balloon->attach( $rm_all_b, -msg => 'Remove all keys' ); $cw->ConfigModelNoteEditor( -object => $hash )->pack(qw/-anchor n/); # set all buttons to their default state $cw->update_state( tklist => '', entry => '' ); $cw->add_warning( $hash, 'edit' )->pack(@fx); $cw->add_info_button()->pack( @fx, qw/-anchor n/ ); $cw->add_summary($hash)->pack(@fx); $cw->add_description($hash)->pack(@fbe1); $cw->ConfigSpecs(-font => [['SELF','DESCENDANTS'], 'font','Font', $cme_font ],); $cw->Tk::Frame::Populate($args); } sub reset_value { my $cw = shift ; $cw->Subwidget('tklist')->delete( 0, 'end' ); $cw->insert( end => $cw->{hash}->fetch_all_indexes ); } # the following function is used to make multi-line keys (like Files # entries in Debian copyright files) more manageable: LF are replaced # by \n to enable editing a multi line entry in a Tk::Entry. sub insert { my $cw = shift ; my $where = shift ; my @what = map { s/\n/\\n/g; $_; } #map { $hash->shorten_idx($_); } @_ ; $cw->Subwidget('tklist')->insert($where => @what); } # this function (not a method) restore the LF in a multi line key # (reverse the operation done above sub restore_keys { return map { s/\\n/\n/g; $_; } @_ ; } sub remove_all_elements { my $cw = shift; my $dialog = $cw->Dialog( -title => "Delete ?", -text => "Are you sure you want to delete all elements ?", -buttons => [qw/Yes No/], -default_button => 'Yes', ); my $answer = $dialog->Show; return unless $answer eq 'Yes'; $cw->{hash}->clear; $cw->Subwidget('tklist')->delete( 0, 'end' ); $cw->reload_tree(); } # update buttons state according to entry and list widget # this method is called whenever one of them changes its content sub update_state { my ( $cw, %content ) = @_; my $wat = \%widget_activation_table; foreach my $button ( keys %$wat ) { my $new = 1; foreach my $c ( keys %content ) { $new &&= $wat->{$button}{$c} || $content{$c}; } my $subwidget = $cw->Subwidget($button) || next; $subwidget->configure( -state => $new ? 'normal' : 'disabled' ); } } sub add_entry { my $cw = shift; my $add = shift; my $tklist = $cw->Subwidget('tklist'); my $hash = $cw->{hash}; $logger->debug("add_entry: $add"); if ( $hash->exists(restore_keys($add)) ) { $cw->Dialog( -title => "Add item error", -text => "Entry $add already exists", )->Show(); return 0; } # add entry in hash eval { $hash->fetch_with_id(restore_keys($add)) }; if ($@) { $cw->Dialog( -title => 'Hash index error', -text => $@->as_string, )->Show; return 0; } $logger->debug( "new hash idx: " . join( ',', $hash->fetch_all_indexes ) ); # ensure correct order for ordered hash my @selected = $tklist->curselection(); $tklist->selectionClear( 0, 'end' ); if ( @selected and $hash->ordered ) { my $idx = $tklist->get( $selected[0] ); $logger->debug("add_entry on ordered hash: swap $idx and $add"); $hash->move_after( restore_keys($add, $idx) ); $logger->debug( "new hash idx: " . join( ',', $hash->fetch_all_indexes ) ); my $new_idx = $selected[0] + 1; $cw->insert( $new_idx, $add ); $tklist->selectionSet($new_idx); $tklist->see($new_idx); } elsif ( $hash->ordered ) { # without selection on ordered hash, items are simply pushed $cw->insert( 'end', $add ); $tklist->selectionSet('end'); $tklist->see('end'); } else { $cw->add_and_sort_item($add); } # trigger redraw of Tk Tree $cw->reload_tree; return 1; } sub add_and_sort_item { my $cw = shift; my $add = shift; my $tklist = $cw->Subwidget('tklist'); my $idx = 0; my $added = 0; $tklist->selectionClear( 0, 'end' ); foreach my $item ( $tklist->get( 0, 'end' ) ) { if ( $add lt $item ) { $cw->insert( $idx, $add ); $tklist->selectionSet($idx); $tklist->see($idx); $added = 1; last; } $idx++; } if ( not $added ) { $cw->insert( 'end', $add ); # last entry $tklist->selectionSet('end'); $tklist->see('end'); } } sub add_item { my $cw = shift; my $add = shift; my $hash = $cw->{hash}; my $tklist = $cw->Subwidget('tklist'); # add entry in tklist if ( $hash->ordered ) { $logger->debug("add_item: adding $add in ordered hash"); $tklist->selectionClear( 0, 'end' ); $cw->insert( 'end', $add ); $tklist->selectionSet('end'); $tklist->see('end'); } else { # add the item so that items are ordered alphabetically $logger->debug("add_item: adding $add in plain hash"); $cw->add_and_sort_item($add); } } sub get_selection { my $cw = shift; my $what = shift; my $tklist = $cw->Subwidget('tklist'); my @from_idx = $tklist->curselection(); if ( not @from_idx ) { $cw->Dialog( -title => "$what selection error", -text => " Please select an item to $what", )->Show(); } return @from_idx; } sub copy_selected_in { my $cw = shift; my $to_name = shift; my $tklist = $cw->Subwidget('tklist'); my @from_idx = $cw->get_selection('copy') or return 0; my $from_name = $tklist->get(@from_idx); if ( $from_name eq $to_name ) { $cw->Dialog( -title => "copy item error", -text => "Cannot copy in the same item ($to_name)", )->Show(); return 0; } my $hash = $cw->{hash}; my $new_idx = $hash->exists(restore_keys($to_name)) ? 0 : 1; $logger->debug( "copy_selected_to: from $from_name to $to_name (is new index: $new_idx)" ); $hash->copy( restore_keys($from_name, $to_name) ); if ($new_idx) { $logger->debug("copy_selected_to: add_item $to_name"); $cw->add_item($to_name); } $cw->reload_tree; } sub move_selected_to { my $cw = shift; my $to_name = shift; my $tklist = $cw->Subwidget('tklist'); my @from_idx = $cw->get_selection('move') or return 0; my $from_name = $tklist->get(@from_idx); if ( $from_name eq $to_name ) { $cw->Dialog( -title => "move item error", -text => "Cannot move in the same item ($to_name)", )->Show(); return 0; } $logger->debug("move_selected_to: from $from_name to $to_name"); my $hash = $cw->{hash}; $tklist->delete(@from_idx); my $new_idx = $hash->exists(restore_keys($to_name)) ? 0 : 1; $hash->move( restore_keys($from_name, $to_name) ); if ($new_idx) { if ( $hash->ordered ) { $tklist->selectionClear( 0, 'end' ); $cw->insert( $from_idx[0], $to_name ); $tklist->selectionSet( $from_idx[0] ); } else { # add the item so that items are ordered alphabetically $cw->add_and_sort_item($to_name); } } $cw->reload_tree; } sub move_selected_up { my $cw = shift; my $tklist = $cw->Subwidget('tklist'); my @idx = $tklist->curselection(); return unless @idx and $idx[0] > 0; my $name = $tklist->get(@idx); $logger->debug("move_selected_up: $name (@idx)"); $tklist->delete(@idx); my $new_idx = $idx[0] - 1; $cw->insert( $new_idx, $name ); $tklist->selectionSet($new_idx); $tklist->see($new_idx); my $hash = $cw->{hash}; $hash->move_up(restore_keys($name)); $logger->debug( "move_up new hash idx: " . join( ',', $hash->fetch_all_indexes ) ); $cw->reload_tree; } sub move_selected_down { my $cw = shift; my $tklist = $cw->Subwidget('tklist'); my @idx = $tklist->curselection(); my $hash = $cw->{hash}; my @h_idx = $hash->fetch_all_indexes; return unless @idx and $idx[0] < $#h_idx; my $name = $tklist->get(@idx); $logger->debug("move_selected_down: $name (@idx)"); $tklist->delete(@idx); my $new_idx = $idx[0] + 1; $cw->insert( $new_idx, $name ); $tklist->selectionSet($new_idx); $tklist->see($new_idx); $hash->move_down(restore_keys($name)); $logger->debug( "move_down new hash idx: " . join( ',', $hash->fetch_all_indexes ) ); $cw->reload_tree; } sub delete_selection { my $cw = shift; my $tklist = $cw->Subwidget('tklist'); my $hash = $cw->{hash}; foreach ( $tklist->curselection() ) { my $idx = $tklist->get($_); $hash->delete(restore_keys($idx)); $tklist->delete($_); $cw->reload_tree; } } sub reload_tree { my $cw = shift; $cw->update_warning( $cw->{hash} ); $cw->{store_cb}->(); } 1; Config-Model-TkUI-1.365/lib/Config/Model/Tk/icons/0000755000175000017500000000000013204357016017754 5ustar domidomiConfig-Model-TkUI-1.365/lib/Config/Model/Tk/icons/next.png0000644000175000017500000000124513204357016021442 0ustar domidomiPNG  IHDRw=gAMA7tEXtSoftwareAdobe ImageReadyqe<7IDATxb?-@11- RpHsc.>$d  k @lCd~4C"Q9q_8^ @̍aaA0? 3ݗa}j}? FQײ[kZ2\{qll!Fƿ~Cs10D: ['3d_0w aDZ00` .°bF7f(H gZ !V 2`7jal˗/aFh@3# 6 ~2ٕ4̢/^0;`͗JteCII0ٳg\d8(oy؛% @{?CAVp @.s9j`)  b(WUUe8v寏=%O Ñ)@`|NP026 @^*&nݺq@1Z^a9q@T0DG@BVH$9!@Z? e`jf@K&AIENDB`Config-Model-TkUI-1.365/lib/Config/Model/Tk/icons/stop.png0000644000175000017500000000153613204357016021454 0ustar domidomiPNG  IHDRw=gAMA7tEXtSoftwareAdobe ImageReadyqe<IDATxb?-@11 Ȉ!?-g͒R~` .30010pr20\(Y_20|г۷5Z` aqɐ~id007C-ZteuuǞȖ  ^cHLd`ؿՂ!>?!`?~pZ^a'a PQv-p ѿ~A|A-`|J x*B 20|0fF?f`xȃ@ ׁ)1\BMA44pw7D b(pi AoLb P-sCa =b8Ppw߼aLFB}KnD !f moO fwۯ P#k << FF !< qpcX@ x dp2$oX Q`X, T @Kp_?13t py-@Vq`wF֔ _)UgULC7ϓ|b;hiBP:Oo R.u>,U}X^`Q=/Mb· |!d(5 8gG\[_EuϞ| N3#v~pw rde;*ުJ:!ճmPbp ͆+6:B/+nCOlWWh5_#y`G'&'$W@u N׀s> !RS+m<''/A@JY G(@`]#: *G??&cߢ*B6 Q~V)u;LBVJqbxIiL0m^wgŢfJ;qqqΝ=>2*,K3 a.i&Ò @0KC@J՞ȋ- RрsMBȫ{cRbΝ?vwy"u3I1@ЁzXaY{7,ʵ'$$cӧO0R!.S!yqi!-JZ<@&)B ͚뵀qٖ-RQzp'Q]C'%wA BHNnn渷PJRwE^gsBr/E5BWRN#@v`؄ 0.5ƴlce琌Kv@)??RiCMM pGSJG 4(x----@Velz4qWʺ3W2<̮U~)&* J-Ȏ{1n tι4!II4Nիu #qp;5h@^lFȂBG\_`4pDoK^i0s HՕz XpL^5<FBhlL L)!M}H) 7%p)cl]w >`@&CG$L{j͆xK,dă-i!,RR 1qgH0Qx4/^^9 LCY}tMHz۷ogf|||RjjZE!^nGvQ=>a Y"BR[¨ ^KXu߱%ga^QS C-ZVJ}sLG3>7Do_  cOxK@äE- xۿ| X#L1GebbGu% Q~цhNjiRS7^%K?9w7yRꑬf?,W 7];(n\sSpsh}zU)psKMGuhEBBbqF~?Ο/Cee%t]WC%rl"N<_›oٿrv+sI6T}q޾zET z ( Xz]+@}? N^0`v{ !Ēf$ޜReKG?*k.تDw,TL'nq ?S7`^[1, ֘ Q LZœ)M4 0444=^BFk*~uZЫpر nOy;=w*Hz S%Q4^9M֘ *sy}*; 2> b楗H9Ϥ~pn ^WJjtӄlڨJAڍq 2Bi3yݺ4 !td77l=#7xE:C`;gR, 10NaUPJ7O2P-a1äBID4٦|gt+]>ѭj1(^kJҢ[%Y1^4 *ڽv `|x5jF4堔z#fc61}-KR*RU0 '%IpzkLn4Qo IFx0%{W[$} p悁W*.ت/_c:T%ˋr 2ݠ w1y' <9V^ Dfו+BV̍Wo1FCs @^驥\`͂ 3\Q ZRǝ ֲ\:h@-!p\4,o8ĴD& ͝;wVK) !D\ݵ$ cZ4,B\+"żtU .y| 6̓sDtС\k\悦XĉI!(eyS}a=Bin#\r[AF1PS9Ú 7]_} 8.,b8Y+e|Iøq0rĈ`' ذq#7l0+RB=]ϖվ>iD:rȠW-В7o-ÇcرB)si&躮!x-*9'=eJ Qӡ%!)ɸ<>s0Z!9s1f(pDιFӦNeC i;J>6mSr[3g`sAAiyB=Yk eMׯ_D Ė-[klDNNbbbZU__:4sr%s>R966vȬ\w{`[%.W Ÿprss$)9'OTEEE if !X[A9D ِ3cDMDݻqQ"99UuqގC}kG:aBC4;77D@:>*' B0 3>_nܴɸP^|}[ȴicŜV1v{Ɍ2IKE3)As"tyy9֯_o(4 |On1pRbȑdʔ)񌱏9磺ZuSYx9n0R:2J)9٠AZǹ.\~!u~~sv3(7.Q(iòdKv։Q ᜧ>!bRSS}8-66ii蓐%%~&DT\ߐR&e(hȑ}ƏjFC޽{kMӜ$8ե %0BȏR_OOOWOp 2nZKl)U)%#j]֐RV51-333cw{4В|4' !:&B83 !5k !"*7V)5B76Փ󹮮k֬:)cBV+9ObmIMMufvv@6U_5>\iĶ]/tx7';Mt!"׬N ]sٷJ5k%RB@;[?}YHiٽ{# ø61 "sRlt-#B lZI{*#!@XھfM|0LE 1M^]]}BJ9Yq%2؛nZT_ڥe6);@@ ?Nyk%46 k%Qa!|A QJaMƹs*: ^xO=7;7כj.-bcǏIA9yS,Im4`/gS!R`mHA ٶmc^Ga24UA딄 &JX`޽ԐRY2@4GN~j+0mTСCk1DM|!{hj;Y @,E!w!bEԣB]Uy!RY%%%}Zӧ{ 4LӴbyBW&_$ I /(ap2gADB$];+)tϪ٣MzB)dϘiZ<*qQ"!G8q8 ۷o7K a%RZV_T|0ףGM/*޾ݧz\߿횦rcG9(:<@_1M'dsYYfcc㗦i`R Æ 3&L=d`hH_ZZ-[lLUYcFɉx<^(((UTT5 #O2DKȋ))) u˗/]!IJ&8cjqvE#]eC)Z,]^#sclUlllYbbcCHPeKcEE`iGTrdzS"dsrw<NR oq?o·XD)]z'NsgGMȱ?~+u}XG+p)5۽hvnnM c ._Ɓ';wcPYYIǏ2dKZ]9BT6PDhGE)pȑ@;.!>B Lohh۾x+b+"I !">>0#B|omܼWYYy=z seox/vo-zY7 Gæi˄F{H!E˗/6 {\)+**BDPJۑ2wnwϝ;s[ 1r1m4 %%Ol2Ps>… =]!RʒQKJJ.{#H}}CXĎTCC邼:SEEE,;{ @@ }}ȬYn4Od-PR())Qb@HHPUcdww;8~1s8dP B0e-sɜo7h QQQtΞJ]zu&i wbc¼qY4 0 Æ -2((eX^+yv!DåKرCJ)Ek oL>ܢ5 бw^ن3݅[o݄ha0BlޠƾާO^xi+9m )?8tP#N(眏0Msܘ1Y^s}B WVU5L `II0~ D)Ezz: Dz)m5!Bǎ+X~=~nedda.ȧBK)~kSa"`=<%m+YR狋~ߑ9'%993ݑN>r䈬-Bw6BWJ9pKMq6)ehѐP~ݳg|i.l+bOPNBM0CJ>jfQYY˦i.|BB)Ϗ`Ŋ?˭agԔ1cO3.]0۳MYxq~VV֢ZiC Xllbp.3榼k֬eeeV2Ѓ@yyq!~0f SF<s<H)Q]]~ڳg.a]ǜ7|sRȎ#Q{V}4ףPJL>i4駟?\˗f\oݗ7s R;R\A9$E.]B=R^!d[Azz˺Hn!7eAH/ Bzn?W!;(IENDB`Config-Model-TkUI-1.365/lib/Config/Model/Tk/icons/fontsizeup.png0000644000175000017500000000044313204357016022671 0ustar domidomiPNG  IHDRĴl;gAMA abKGD pHYs  ~tIME 6 7eIDATxSI yhO@JU/@ކ 7\$!b#R~D#h t9ծF,P6aQ̈ZZZ1ϵxWf̺jʧp?I9Ԑ}ur5! ͣXW q%zJ`^IENDB`Config-Model-TkUI-1.365/lib/Config/Model/Tk/icons/remove.png0000644000175000017500000000242113204357016021756 0ustar domidomiPNG  IHDRĴl;sBIT|dtEXtSoftwarewww.inkscape.org<IDAT8]hSg$i&iiڦӔ~$"~]t(:!ވlu x1.` 2/d mU6tX*8ڭ6Ka?$'9]s]L]nxn?ϏtL\#ji*t/L>D^"\˱oVWˮ rggy33ՕjZIrE!snwhbXe={~pg IDAT8_h[Uﹹijrz6+vsc0E&SAgũ]vvm'lВ<(yYY>hq v)NBkэ26 oniɽs|Ӳv~~p~~DJ#bEQ]BXHy@8;ⳆfX$0drN !幯\=RRLǎt^ځB!M+[o83>`@J ^ҙ#==]Er岹l.AUXYC:$^X8#8\'sy(%Qk`hllIn~1f..-RN J)oP#G8Rbx'QNy Un;<NU( !$fs\T%ګAB۶=t:/>7->=P@sޚuޚjUINe}kҋ/>}d(,EHPn,AԢ+Q,cJ>[*mbJ15;"Lb`hp h6P(׎)D4RCQrx_h;8xL>&PF5h0oTUn ʵrF &+8„Rf:O330xS__#TB;] 7;xw_&ILܚfvv> @`ZFG!<J (;}F>f9+sw-c{lyΩ:dձ|3.cw'>#{GC>Ljt0y)y|`&ЇX.f̵kX66|xg⓲㶾ˌvtb ^{>iq2G\QAz 3AB#м$R^|М&Eu@!X߃591+yOn-cnU0`j3B\L=;BWUigm>hAa⡄bu {>ZH?;>!. q)"\xŷh$żD@,:^w@W״>=L <,\J9wi7Nδ ?!1#M,UZnS\_ Hs Yϕ|7ջ5%)roE;b'GosOpm_NFj9xn<I٥Gr1(B̒^%*IENDB`Config-Model-TkUI-1.365/lib/Config/Model/Tk/icons/up.png0000644000175000017500000000324013204357016021105 0ustar domidomiPNG  IHDRw=gAMA7tEXtSoftwareAdobe ImageReadyqe<2IDATxbd8X Y@Ĉ` bf U 2?LHϟ?"fC]Ņ߽ٙ{?߾}֭[_011-`ZxΝ;/  t  SQQ'Oo@>߹21?@ ~ |ч0@LV___"6ŋ_qy/vlN f Ǐ9Nnذ)PbD s3 j7oܸqðgwn`KA@0<]K.@T`100)ҥKOoh?蕒acظ ޠ`?@P ] FMoww̷o߾^v֭[?.//??ûl=Ah/_ fhR.7o|F͛73-;r~7zOaO6lk888AA _D$}KNoA. d ĄLl0F: hf E C# 9oAŰ.P2hſOE? /.CP˗U<<< `p[`21C`7ܲ o^cF*0J-t`l40xRs(Aɵ@I?$ÁûoNV QLhP$3b/}? ",,rLho~b&'ɞ2`Re P>_`*b&ۿ-Ae (#0%0Po?~e L S+fa@dѠ<@"(i .Pe0P "Pz~zPDa9 hy2YX?(@|ky$?!. /(Bh cx@s|`~@ pF fLpAA>r98xDPPR@ٙ (#@"Pe@ 4h OO}v0y;`5zXa_@?`R @` @57h xf R{pФBC,@P섎G:BpX(++V4YA9XL8G($JJJgaf3? @@,E"I%(` ?t%d3B}' E/(ApPD#0H~`Q<bfZ$ *AsB/OtJԂ JBTIENDB`Config-Model-TkUI-1.365/lib/Config/Model/Tk/icons/add.png0000644000175000017500000000151213204357016021211 0ustar domidomiPNG  IHDRĴl;sBIT|dtEXtSoftwarewww.inkscape.org<IDAT8oE?7#A!z\#$ D>U !j DҐ l.2QL''pޝ)3|>%"5++߶Vc~_^_{ottT> ~sοeb0عLX%(s,#X ~,*5{ЧaOa4e)ea0epX|K +f0Xe寖?9} )'RxJ8ED=\ enwfJ <Զ/S;[li⼫ҷ6?p ;7XO{,=A$D +ZI2z)- n(P՚mqa nw6]Cb2+̍ .e-nʭɈܳ-X1}fB}|[[ݙmw<pP^ʼnzU'?F8.ggQ<=W'kk˚D"DELflBp=Տh4y䛛?*6En'itfb3|Fqa6d 5ztZPT\nڥ3Ȇ<|Kq#+ZqNaHc< 4(*X(QBS8tXJdC3NV;;'>۶lGٟ:L($ <ܕIENDB`Config-Model-TkUI-1.365/lib/Config/Model/Tk/icons/dbgrun.png0000644000175000017500000000036413204357016021746 0ustar domidomiPNG  IHDRĴl;bKGDiBըIDATx EQ6O)2 Kx~bZU:\xB2YfozpG / ";yZLDgʊ{xKzٕ V\? ؿP<M|O'4uZ/~"U?\etFTIENDB`Config-Model-TkUI-1.365/lib/Config/Model/Tk/icons/gnome-previous.png0000644000175000017500000000212713204357016023443 0ustar domidomiPNG  IHDRĴl;sBIT|d pHYs B(xtEXtSoftwarewww.inkscape.org<tEXtTitleOptical Drive>g IDAT8]HWuwV["cm: }+DDm@Saa!Fl CK"XyCcHWviWYs6!$yr9C?¿Ӆ+WyyOt`n7c{~q"W9`վFL=eaOp<W':A !ȩHj7(!≸J877*RX~24_edb---鋟^,ɣ.e:%$aZcbi_OKt\ȠisWkDS?jG*=YPph>=wW^Dƺ}O9o^q<|pX*(RFF)e^VuF@vu0ERsff7Ca/܁,ɈiVug @[[,[H&L&Y133dYƻO8G0bRmi_ cm]V!D(˛ٱKKOˎBXB$OݽGKņ‚WWoLOM~UgVv!J?@n+mò|,_ğw<)IENDB`Config-Model-TkUI-1.365/lib/Config/Model/Tk/icons/down.png0000644000175000017500000000304513204357016021433 0ustar domidomiPNG  IHDRw=gAMA7tEXtSoftwareAdobe ImageReadyqe<IDATxbd8X Y@Ĉ` bf U 2?LHϟ?"fC]Ņ߽ٙ{?߾}֭[_011-`ZxΝ;/  t  SQQ'Oo@>߹21?@ ~ |ч0@LV___"_B:EX@Cv6lx  0 p{{{5PX]xӟ ! $n~?C ###0DEE}.] `"?(X @At {``0Z @P ] &%/(yyy~㷶nH 2 Xh fae*++Ι)KFFFٳg߼yy۶m%%% >&?@`>kA`2_888YYY;99I%~_\/еAYf,>>>X03,a`<,adff hL^ly{ʕ4IPP} .X@@MIIGfE`O 6gˑ-HPT$ p{޿=@f ;g\/$^ګ<ɓDo}pUs5J@@,A9Cd{Z΀87HA6?pϰ7`;V%á/@Ұ(rrrbFGKm_ Ca FAQ7T\ A [zo[ K!; faFy Z3  r% ԏ{7?oq:   @@ A zUSma+\^ PR@ٙ l~ pl* W  T Hp`no; LBsP J5 xi/ &h@ h 0ɲ .ZX9#qfaxj L8/ H(vBGG#lBp偶[(++V4A???r,013a98BAa JJJgaf3? 9PdJY |3?@Ïw LbFn߾!E/(A(l#0H~ '#T-"z9h'P:%EPje@VUlYIENDB`Config-Model-TkUI-1.365/lib/Config/Model/Tk/icons/rotate_cw.png0000644000175000017500000000221413204357016022450 0ustar domidomiPNG  IHDRĴl;sBIT|dtEXtSoftwarewww.inkscape.org<IDAT8]LU=}h)0`0 Am\ &MnFܲ SQq7^(jt&2apY6HbJ }f↉9ϓQUU7\Zs' !P`= ܨT92 u 1LB6aZ$YB\D1HpS5㫂eZ9bCC>U 7$ҔBuڴzsb*A~ƪ(p'\\#\;J#+ %”O7dU8Ӕ`y{ ϭ=RepSAf\-ROj&+|_?8֖lj@]FqJdF݉Bcg^Á7:!];˾/93#i6 )HII[֧HДF aIz4z`Thڽ0d5)[ $&˨U괚I@gEQC ߬+NnV8?2I#3Z˟j_זWRqͻ^awf,0Pl䌏7lRK+>4>' } j PL]%Ep}/ ^)˴rD~(z$ 5CIENDB`Config-Model-TkUI-1.365/lib/Config/Model/Tk/icons/eraser.png0000644000175000017500000000231213204357016021741 0ustar domidomiPNG  IHDRĴl;sBIT|dtEXtSoftwarewww.inkscape.org<\IDAT8[lUƿs^fBUjQBE5\#Ś(ES⍘hP#&ByՄi& ٺ*mY7[?۹!y=*iVn\i֓|؏Z{2?Mq'1! $ARGV[0]) : () ; my $build = Module::Build->new ( module_name => 'Config::Model::TkUI', @version_info, license => 'lgpl', dist_abstract => "Tk GUI to edit config data through Config::Model", dist_author => "Dominique Dumont (ddumont at cpan dot org)", 'build_requires' => { 'Config::Model::Value' => '0', 'Module::Build' => '0.34', 'Test::Memory::Cycle' => '0', 'Test::More' => '0', 'Test::Warn' => '0.11' }, 'configure_requires' => { 'Module::Build' => '0.34' }, 'requires' => { 'Carp' => '0', 'Config::Model' => '2.114', 'Config::Model::ObjTreeScanner' => '0', 'File::HomeDir' => '0', 'Log::Log4perl' => '1.11', 'Path::Tiny' => '0', 'Pod::POM' => '0', 'Pod::POM::View::Text' => '0', 'Scalar::Util' => '0', 'Text::Diff' => '0', 'Text::Wrap' => '0', 'Tk' => '0', 'Tk::Adjuster' => '0', 'Tk::Balloon' => '0', 'Tk::BrowseEntry' => '0', 'Tk::Dialog' => '0', 'Tk::DialogBox' => '0', 'Tk::DirSelect' => '0', 'Tk::DoubleClick' => '0', 'Tk::FontDialog' => '0', 'Tk::Frame' => '0', 'Tk::Menubutton' => '0', 'Tk::NoteBook' => '0', 'Tk::PNG' => '0', 'Tk::Pane' => '0', 'Tk::Photo' => '0', 'Tk::Pod' => '0', 'Tk::Pod::Text' => '0', 'Tk::ROText' => '0', 'Tk::Toplevel' => '0', 'Tk::Tree' => '0', 'Try::Tiny' => '0', 'YAML' => '0', 'perl' => '5.010' }, add_to_cleanup => [qw/stderr.log wr_data/] , ); $build->add_build_element('png'); $build->create_build_script;