├── .gitignore ├── .travis.yml ├── LICENSE ├── META6.json ├── README.md ├── Todo ├── examples ├── CustomSetup │ ├── CustomSetup.pm6 │ └── DataSource.pm6 ├── JSON_filter.pl6 ├── JSON_folding.pl6 ├── JSON_parsed.pl6 ├── README.md ├── all.pl6 ├── all_color_blob.pl6 ├── all_folding.pl6 ├── background_color.pl6 ├── but.pl6 ├── caller_name_title.pl6 ├── callframe.pl6 ├── custom_setup.pl6 ├── data_source.pl6 ├── ddt.pl6 ├── dhtml.pl6 ├── diff.pl6 ├── diff_string.pl6 ├── filter1.pl6 ├── flat.pl6 ├── folding.pl6 ├── glyphs_color.pl6 ├── gumbo.pl6 ├── highlight.pl6 ├── html.pl6 ├── int32.pl6 ├── jddt.pl6 ├── jflat.pl6 ├── junctions.pl6 ├── long_folding.pl6 ├── match.pl6 ├── named_captures.pl6 ├── named_elements.pl6 ├── paths.pl6 ├── perltricks_examples.pl6 ├── remote │ ├── fold_receive.pl6 │ ├── fold_send.pl6 │ ├── lfl.pl6 │ ├── receive.pl6 │ └── send_big.pl6 ├── removal.pl6 ├── sequences_pairs.pl6 ├── two_columns.pl6 ├── untyped_elements.pl6 └── wrap_and_highlight.pl6 ├── lib └── Data │ └── Dump │ ├── Tree.pm6 │ ├── Tree.pod │ └── Tree │ ├── ColorBlobLevel.pm6 │ ├── Colorizer.pm6 │ ├── DHTML.pm6 │ ├── DHTML.pod │ ├── Ddt.pm6 │ ├── DescribeBaseObjects.pm6 │ ├── Diff.pm6 │ ├── Diff.pod │ ├── Enums.pm6 │ ├── ExtraRoles.pm6 │ ├── Foldable.pm6 │ ├── Horizontal.pm6 │ ├── LayHorizontal.pm6 │ ├── MultiColumns.pm6 │ └── TerminalFoldable.pm6 ├── t ├── 00_use.t ├── 01_all.t ├── 03_multiple_arguments.t ├── 04_flat.t ├── 05_class_attributes.t ├── 06_role_attributes.t ├── 10_role.t ├── 11_class_vs_role.t ├── 12_extra_standard_roles.t ├── 13_named_captures.t ├── 14.Match_limit.t ├── 20_nothing.t ├── 21_terminal.t ├── 31_default_base_class.t ├── 32.exception.t ├── 40_type_Map.t ├── 41_type_callframe.t ├── 42_type_Map.t ├── 43_sequences.t ├── 44.pair.t ├── 45_junctions.t ├── 46_Bool.t ├── 47_type_Set.t ├── 48_type_NativeCall.t ├── 49_Buf.t ├── 50_Bag.t ├── 51_Slip.t ├── 70_sub_interface.t ├── 71_filter.t ├── 80_title.t ├── 81_color.t ├── 82_max_depth.t ├── 83_width.t └── 90_foldable.t └── xt └── 02_META.t /.gitignore: -------------------------------------------------------------------------------- 1 | .precomp 2 | *.swp 3 | *.swo 4 | *.swn 5 | 6 | -------------------------------------------------------------------------------- /.travis.yml: -------------------------------------------------------------------------------- 1 | language: perl6 2 | 3 | sudo: false 4 | 5 | perl6: 6 | - latest 7 | 8 | install: 9 | - rakudobrew build-zef 10 | - zef install --depsonly . 11 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | The Artistic License 2.0 2 | 3 | Copyright (c) 2000-2015, The Perl Foundation. 4 | 5 | Everyone is permitted to copy and distribute verbatim copies 6 | of this license document, but changing it is not allowed. 7 | 8 | Preamble 9 | 10 | This license establishes the terms under which a given free software 11 | Package may be copied, modified, distributed, and/or redistributed. 12 | The intent is that the Copyright Holder maintains some artistic 13 | control over the development of that Package while still keeping the 14 | Package available as open source and free software. 15 | 16 | You are always permitted to make arrangements wholly outside of this 17 | license directly with the Copyright Holder of a given Package. If the 18 | terms of this license do not permit the full use that you propose to 19 | make of the Package, you should contact the Copyright Holder and seek 20 | a different licensing arrangement. 21 | 22 | Definitions 23 | 24 | "Copyright Holder" means the individual(s) or organization(s) 25 | named in the copyright notice for the entire Package. 26 | 27 | "Contributor" means any party that has contributed code or other 28 | material to the Package, in accordance with the Copyright Holder's 29 | procedures. 30 | 31 | "You" and "your" means any person who would like to copy, 32 | distribute, or modify the Package. 33 | 34 | "Package" means the collection of files distributed by the 35 | Copyright Holder, and derivatives of that collection and/or of 36 | those files. A given Package may consist of either the Standard 37 | Version, or a Modified Version. 38 | 39 | "Distribute" means providing a copy of the Package or making it 40 | accessible to anyone else, or in the case of a company or 41 | organization, to others outside of your company or organization. 42 | 43 | "Distributor Fee" means any fee that you charge for Distributing 44 | this Package or providing support for this Package to another 45 | party. It does not mean licensing fees. 46 | 47 | "Standard Version" refers to the Package if it has not been 48 | modified, or has been modified only in ways explicitly requested 49 | by the Copyright Holder. 50 | 51 | "Modified Version" means the Package, if it has been changed, and 52 | such changes were not explicitly requested by the Copyright 53 | Holder. 54 | 55 | "Original License" means this Artistic License as Distributed with 56 | the Standard Version of the Package, in its current version or as 57 | it may be modified by The Perl Foundation in the future. 58 | 59 | "Source" form means the source code, documentation source, and 60 | configuration files for the Package. 61 | 62 | "Compiled" form means the compiled bytecode, object code, binary, 63 | or any other form resulting from mechanical transformation or 64 | translation of the Source form. 65 | 66 | 67 | Permission for Use and Modification Without Distribution 68 | 69 | (1) You are permitted to use the Standard Version and create and use 70 | Modified Versions for any purpose without restriction, provided that 71 | you do not Distribute the Modified Version. 72 | 73 | 74 | Permissions for Redistribution of the Standard Version 75 | 76 | (2) You may Distribute verbatim copies of the Source form of the 77 | Standard Version of this Package in any medium without restriction, 78 | either gratis or for a Distributor Fee, provided that you duplicate 79 | all of the original copyright notices and associated disclaimers. At 80 | your discretion, such verbatim copies may or may not include a 81 | Compiled form of the Package. 82 | 83 | (3) You may apply any bug fixes, portability changes, and other 84 | modifications made available from the Copyright Holder. The resulting 85 | Package will still be considered the Standard Version, and as such 86 | will be subject to the Original License. 87 | 88 | 89 | Distribution of Modified Versions of the Package as Source 90 | 91 | (4) You may Distribute your Modified Version as Source (either gratis 92 | or for a Distributor Fee, and with or without a Compiled form of the 93 | Modified Version) provided that you clearly document how it differs 94 | from the Standard Version, including, but not limited to, documenting 95 | any non-standard features, executables, or modules, and provided that 96 | you do at least ONE of the following: 97 | 98 | (a) make the Modified Version available to the Copyright Holder 99 | of the Standard Version, under the Original License, so that the 100 | Copyright Holder may include your modifications in the Standard 101 | Version. 102 | 103 | (b) ensure that installation of your Modified Version does not 104 | prevent the user installing or running the Standard Version. In 105 | addition, the Modified Version must bear a name that is different 106 | from the name of the Standard Version. 107 | 108 | (c) allow anyone who receives a copy of the Modified Version to 109 | make the Source form of the Modified Version available to others 110 | under 111 | 112 | (i) the Original License or 113 | 114 | (ii) a license that permits the licensee to freely copy, 115 | modify and redistribute the Modified Version using the same 116 | licensing terms that apply to the copy that the licensee 117 | received, and requires that the Source form of the Modified 118 | Version, and of any works derived from it, be made freely 119 | available in that license fees are prohibited but Distributor 120 | Fees are allowed. 121 | 122 | 123 | Distribution of Compiled Forms of the Standard Version 124 | or Modified Versions without the Source 125 | 126 | (5) You may Distribute Compiled forms of the Standard Version without 127 | the Source, provided that you include complete instructions on how to 128 | get the Source of the Standard Version. Such instructions must be 129 | valid at the time of your distribution. If these instructions, at any 130 | time while you are carrying out such distribution, become invalid, you 131 | must provide new instructions on demand or cease further distribution. 132 | If you provide valid instructions or cease distribution within thirty 133 | days after you become aware that the instructions are invalid, then 134 | you do not forfeit any of your rights under this license. 135 | 136 | (6) You may Distribute a Modified Version in Compiled form without 137 | the Source, provided that you comply with Section 4 with respect to 138 | the Source of the Modified Version. 139 | 140 | 141 | Aggregating or Linking the Package 142 | 143 | (7) You may aggregate the Package (either the Standard Version or 144 | Modified Version) with other packages and Distribute the resulting 145 | aggregation provided that you do not charge a licensing fee for the 146 | Package. Distributor Fees are permitted, and licensing fees for other 147 | components in the aggregation are permitted. The terms of this license 148 | apply to the use and Distribution of the Standard or Modified Versions 149 | as included in the aggregation. 150 | 151 | (8) You are permitted to link Modified and Standard Versions with 152 | other works, to embed the Package in a larger work of your own, or to 153 | build stand-alone binary or bytecode versions of applications that 154 | include the Package, and Distribute the result without restriction, 155 | provided the result does not expose a direct interface to the Package. 156 | 157 | 158 | Items That are Not Considered Part of a Modified Version 159 | 160 | (9) Works (including, but not limited to, modules and scripts) that 161 | merely extend or make use of the Package, do not, by themselves, cause 162 | the Package to be a Modified Version. In addition, such works are not 163 | considered parts of the Package itself, and are not subject to the 164 | terms of this license. 165 | 166 | 167 | General Provisions 168 | 169 | (10) Any use, modification, and distribution of the Standard or 170 | Modified Versions is governed by this Artistic License. By using, 171 | modifying or distributing the Package, you accept this license. Do not 172 | use, modify, or distribute the Package, if you do not accept this 173 | license. 174 | 175 | (11) If your Modified Version has been derived from a Modified 176 | Version made by someone other than you, you are nevertheless required 177 | to ensure that your Modified Version complies with the requirements of 178 | this license. 179 | 180 | (12) This license does not grant you the right to use any trademark, 181 | service mark, tradename, or logo of the Copyright Holder. 182 | 183 | (13) This license includes the non-exclusive, worldwide, 184 | free-of-charge patent license to make, have made, use, offer to sell, 185 | sell, import and otherwise transfer the Package with respect to any 186 | patent claims licensable by the Copyright Holder that are necessarily 187 | infringed by the Package. If you institute patent litigation 188 | (including a cross-claim or counterclaim) against any party alleging 189 | that the Package constitutes direct or contributory patent 190 | infringement, then this Artistic License to you shall terminate on the 191 | date that such litigation is filed. 192 | 193 | (14) Disclaimer of Warranty: 194 | THE PACKAGE IS PROVIDED BY THE COPYRIGHT HOLDER AND CONTRIBUTORS "AS 195 | IS" AND WITHOUT ANY EXPRESS OR IMPLIED WARRANTIES. THE IMPLIED 196 | WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE, OR 197 | NON-INFRINGEMENT ARE DISCLAIMED TO THE EXTENT PERMITTED BY YOUR LOCAL 198 | LAW. UNLESS REQUIRED BY LAW, NO COPYRIGHT HOLDER OR CONTRIBUTOR WILL 199 | BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, OR CONSEQUENTIAL 200 | DAMAGES ARISING IN ANY WAY OUT OF THE USE OF THE PACKAGE, EVEN IF 201 | ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 202 | 203 | -------------------------------------------------------------------------------- /META6.json: -------------------------------------------------------------------------------- 1 | { 2 | 3 | "perl" : "6.c", 4 | 5 | "name" : "Data::Dump::Tree", 6 | "license" : "Artistic-2.0", 7 | "version" : "2.8.0", 8 | "auth" : "github:nkh", 9 | "authors" : ["Nadim Khemir"], 10 | 11 | "description" : "Render data structures as trees; user definable filters", 12 | "provides" : 13 | { 14 | "DDT" : "lib/Data/Dump/Tree.pm6", 15 | 16 | "Data::Dump::Tree" : "lib/Data/Dump/Tree.pm6", 17 | "Data::Dump::Tree::DescribeBaseObjects" : "lib/Data/Dump/Tree/DescribeBaseObjects.pm6", 18 | "Data::Dump::Tree::Enums" : "lib/Data/Dump/Tree/Enums.pm6", 19 | 20 | "Data::Dump::Tree::ExtraRoles" : "lib/Data/Dump/Tree/ExtraRoles.pm6", 21 | "DDTR::ColorBlobLevel" : "lib/Data/Dump/Tree/ColorBlobLevel.pm6", 22 | "Data::Dump::Tree::Colorizer" : "lib/Data/Dump/Tree/Colorizer.pm6", 23 | 24 | "Data::Dump::Tree::Diff" : "lib/Data/Dump/Tree/Diff.pm6", 25 | "Data::Dump::Tree::DHTML" : "lib/Data/Dump/Tree/DHTML.pm6", 26 | "Data::Dump::Tree::Ddt" : "lib/Data/Dump/Tree/Ddt.pm6", 27 | 28 | "Data::Dump::Tree::Foldable" : "lib/Data/Dump/Tree/Foldable.pm6", 29 | "Data::Dump::Tree::TerminalFoldable" : "lib/Data/Dump/Tree/TerminalFoldable.pm6", 30 | 31 | "Data::Dump::Tree::LayHorizontal" : "lib/Data/Dump/Tree/LayHorizontal.pm6", 32 | "Data::Dump::Tree::Horizontal" : "lib/Data/Dump/Tree/Horizontal.pm6", 33 | "Data::Dump::Tree::MultiColumns" : "lib/Data/Dump/Tree/MultiColumns.pm6" 34 | }, 35 | 36 | "depends" : [ "Terminal::Print" ], 37 | "test-depends" : [ "Test", "Test::META" ], 38 | 39 | "tags" : 40 | [ 41 | "data", 42 | "dump", 43 | "render", 44 | "presentation", 45 | "diff", 46 | "HTML", 47 | "Layout", 48 | "dumper", 49 | "color", 50 | "tree" 51 | ], 52 | 53 | "source-url" : "https://github.com/nkh/P6-Data-Dump-Tree.git" 54 | } 55 | 56 | -------------------------------------------------------------------------------- /examples/CustomSetup/CustomSetup.pm6: -------------------------------------------------------------------------------- 1 | 2 | use Data::Dump::Tree ; 3 | use Data::Dump::Tree::ExtraRoles ; 4 | use Data::Dump::Tree::Enums ; 5 | 6 | role CustomSetup is export 7 | { 8 | 9 | method custom_setup 10 | { 11 | self does DDTR::FixedGlyphs ; 12 | self does DDTR::MatchDetails ; 13 | self does DDTR::SuperscribeType ; 14 | self does DDTR::SuperscribeAddress ; 15 | self does DDTR::PerlString ; 16 | 17 | $.color_kbs = True ; 18 | $.display_address = DDT_DISPLAY_NONE ; 19 | $.elements_filters.push: &elements_filter ; 20 | } 21 | 22 | sub elements_filter($dumper, $s, ($, $, $, $element), @sub_elements) 23 | { 24 | my ($k, $b) = $element ; 25 | @sub_elements = @sub_elements.grep({$_[0] ne '' }) if $k eq "" ; 26 | } 27 | 28 | } #role 29 | 30 | -------------------------------------------------------------------------------- /examples/CustomSetup/DataSource.pm6: -------------------------------------------------------------------------------- 1 | 2 | role DataSource is export 3 | { 4 | 5 | use Data::Dump::Tree::ExtraRoles ; 6 | 7 | method custom_setup 8 | { 9 | self does DDTR::FixedGlyphs('') ; 10 | self.width = Inf ; 11 | self.tab_size = 0 ; 12 | self.keep_paths = True ; 13 | 14 | multi sub path_and_tab($, $, $, ($, $path, $, $), (\k, \b, \v, \f, $, $)) 15 | { 16 | k = $path.map({.[1]}).join('%') ~ "\t" ~ k ; 17 | *~= "\t" for k, b, v, f ; 18 | } 19 | 20 | $.header_filters.push: &path_and_tab ; 21 | } 22 | 23 | } #role 24 | 25 | -------------------------------------------------------------------------------- /examples/JSON_filter.pl6: -------------------------------------------------------------------------------- 1 | 2 | use Data::Dump::Tree ; 3 | use Data::Dump::Tree::Enums ; 4 | use Data::Dump::Tree::ExtraRoles ; 5 | 6 | # use json parser 7 | use JSON::Tiny ; 8 | 9 | # The Json that needs parsing 10 | my $JSON = 11 | Q<<{ 12 | "glossary": { 13 | "title": "example glossary", 14 | "GlossDiv": { 15 | "integer": 1, 16 | "title": "S", 17 | "GlossList": { 18 | "GlossEntry": { 19 | "ID": "SGML", 20 | "SortAs": "SGML", 21 | "GlossTerm": "Standard Generalized Markup Language", 22 | "Acronym": "SGML", 23 | "Abbrev": "ISO 8879:1986", 24 | "GlossDef": { 25 | "para": "A meta-markup language, used to create markup languages such as DocBook.", 26 | "GlossSeeAlso": [ 27 | "GML", 28 | "XML" 29 | ] 30 | }, 31 | "GlossSee": "markup" 32 | } 33 | } 34 | } 35 | } 36 | }>> ; 37 | 38 | # dump with DDT 39 | my $d = Data::Dump::Tree.new: 40 | :title, 41 | :display_address(DDT_DISPLAY_NONE) ; 42 | 43 | say q:to/EOC/ ; 44 | Say we have a many small json glossaries to display. We could diplay 45 | them in json or we could mangle them a bit to make them a bit more 46 | easy on the eye. 47 | EOC 48 | $JSON.say ; 49 | ''.say ; 50 | 51 | say q:to/EOC/ ; 52 | First render it with Data::Dump::Tree default settings. 53 | EOC 54 | $d.ddt: from-json($JSON), :nl ; 55 | 56 | say q:to/EOC/ ; 57 | For small renderings of an entry type we know, removing the types reduces 58 | the noise. 59 | EOC 60 | $d.ddt: from-json($JSON), :nl, :!display_type ; 61 | 62 | 63 | say q:to/EOC/ ; 64 | There is a significant difference between the json rendering and DDT 65 | rendering; the json was hand written and the author wrote it as clearly 66 | as possible, she wrote terminal entries (ints, strings, ...) before she 67 | wrote sub elements (hashes, arrays). DDT sorts the keys so that fine 68 | tunning is lost. 69 | 70 | We can render the json with a filter that would put the non terminal 71 | entries first. 72 | EOC 73 | $d.ddt: from-json($JSON), :nl, :!display_type, :elements_filters[&final_first] ; 74 | 75 | say q:to/EOC/ ; 76 | Better but we can reduce the noise a bit, we can remove the binders for 77 | non-terminal elements with a filter, like this: 78 | EOC 79 | $d.ddt: from-json($JSON), :nl, :!display_type, :elements_filters[&final_first, &non_final_no_binder] ; 80 | 81 | say q:to/EOC/ ; 82 | Even better. I like aligned values, I think it is more redable. 83 | EOC 84 | $d.ddt: from-json($JSON), :nl, :!display_type, :elements_filters[&final_first, &non_final_no_binder, &align_keys] ; 85 | 86 | 87 | say q:to/EOC/ ; 88 | We can get the glossary entry out of the json container. 89 | EOC 90 | $d.ddt: from-json($JSON), 91 | :title 92 | :nl, 93 | :!display_type, 94 | :elements_filters[&final_first, &non_final_no_binder, &align_keys] ; 95 | 96 | 97 | say q:to/EOC/ ; 98 | We can remove the tree and throw in some color. 99 | EOC 100 | $d does DDTR::FixedGlyphs(' ') ; 101 | $d.ddt: from-json($JSON), 102 | :title 103 | :nl, 104 | :!display_type, 105 | :color_kbs, 106 | :elements_filters[&final_first, &non_final_no_binder, &align_keys] ; 107 | 108 | say q:to/EOC/ ; 109 | And finally the hand craft json again for comparison. The json 110 | rendering is 25 lines long, mangled rendering is 18 lines long. 111 | EOC 112 | $JSON.say ; 113 | 114 | sub final_first($dumper, $, $, @sub_elements) 115 | { 116 | @sub_elements = @sub_elements.sort: { $dumper.get_element_header($^a[2])[2] !~~ DDT_FINAL } 117 | } 118 | 119 | sub non_final_no_binder ($dumper, $, $, @sub_elements) 120 | { 121 | for @sub_elements -> ($k, $binder is rw, $value, $) 122 | { 123 | $binder = '' if $dumper.get_element_header($value)[2] !~~ DDT_FINAL ; 124 | } 125 | } 126 | 127 | sub align_keys ($dumper, $, $, @sub_elements) 128 | { 129 | my $max_kb = ( my @cache = @sub_elements.map: { (.[0] ~ .[1]).chars }).max ; 130 | 131 | for @sub_elements Z @cache -> (@e, $l) { @e[0] ~= ' ' x $max_kb - $l } 132 | } 133 | 134 | -------------------------------------------------------------------------------- /examples/JSON_folding.pl6: -------------------------------------------------------------------------------- 1 | 2 | use Data::Dump::Tree ; 3 | use Data::Dump::Tree::Enums ; 4 | use Data::Dump::Tree::ExtraRoles ; 5 | use Data::Dump::Tree::DescribeBaseObjects ; 6 | 7 | use JSON::Tiny ; 8 | 9 | sub MAIN(Bool :$debug) 10 | { 11 | # The Json that needs parsing 12 | my $JSON = 13 | Q<<{ 14 | "glossary": { 15 | "title": "example glossary", 16 | "GlossDiv": { 17 | "title": "S", 18 | "GlossList": { 19 | "GlossEntry": { 20 | "ID": "SGML", 21 | "SortAs": "SGML", 22 | "GlossTerm": "Standard Generalized Markup Language", 23 | "Acronym": "SGML", 24 | "Abbrev": "ISO 8879:1986", 25 | "GlossDef": { 26 | "para": "A meta-markup language, used to create markup languages such as DocBook.", 27 | "GlossSeeAlso": ["GML", "XML"] 28 | }, 29 | "GlossSee": "markup" 30 | } 31 | } 32 | } 33 | } 34 | }>> ; 35 | 36 | # parse data 37 | my $parsed = JSON::Tiny::Grammar.parse: $JSON ; 38 | 39 | # dump with DDT 40 | my $d = Data::Dump::Tree.new: 41 | :title, 42 | :display_address(DDT_DISPLAY_NONE), 43 | :does(DDTR::MatchDetails, DDTR::PerlString), 44 | :header_filters[&header_filter], 45 | :elements_filters[&elements_filter] ; 46 | 47 | $d.match_string_limit = 40 ; 48 | $d.dump: $parsed ; 49 | 50 | use Data::Dump::Tree::TerminalFoldable ; 51 | display_foldable(:$debug, $parsed, :ddt_is($d), :title) ; 52 | } 53 | 54 | 55 | sub header_filter($dumper, \r, $s, ($depth, $path, $glyph, @renderings), (\k, \b, \v, \f, \final, \want_address)) 56 | { 57 | # simplifying the dump, this is optional 58 | 59 | # with a value that has no sub elements can be displayed in a more compact way 60 | if k eq "" 61 | { 62 | my %caps = $s.caps ; 63 | 64 | if %caps.caps[0][0].key eq 'string' 65 | { 66 | v = ls(~%caps, 40) ~ ' => ' ~ ls(~%caps, 40) ; 67 | final = DDT_FINAL ; 68 | } 69 | } 70 | 71 | # "" | "" | "" | '' need no details 72 | if k eq "" | "" | "" | '' 73 | { 74 | v = '' ; 75 | f = '' ; 76 | } 77 | 78 | } 79 | 80 | sub elements_filter($dumper, $s, ($depth, $glyph, @renderings, $element), @sub_elements) 81 | { 82 | # simplifying the dump, this is optional 83 | 84 | my ($k, $b) = $element ; 85 | 86 | # matches will have two elements that add nothing to the dump, remove them 87 | @sub_elements = () if $k eq '' ; 88 | 89 | # has a element that add nothing to the dump; remove it 90 | @sub_elements = @sub_elements.grep({$_[0] ne '' }) if $k eq "" ; 91 | } 92 | 93 | 94 | # helper sub 95 | 96 | sub ls(Str $s, $limit) 97 | { 98 | if $limit.defined && $s.chars > $limit 99 | { 100 | $s.substr(0, $limit) ~ '(+' ~ $s.chars - $limit ~ ')' 101 | } 102 | else 103 | { 104 | $s 105 | } 106 | } 107 | 108 | 109 | -------------------------------------------------------------------------------- /examples/JSON_parsed.pl6: -------------------------------------------------------------------------------- 1 | 2 | use Data::Dump::Tree ; 3 | use Data::Dump::Tree::Enums ; 4 | use Data::Dump::Tree::ExtraRoles ; 5 | use Data::Dump::Tree::DescribeBaseObjects ; 6 | 7 | # use json parser 8 | use JSON::Tiny ; 9 | 10 | # The Json that needs parsing 11 | my $JSON = 12 | Q<<{ 13 | "glossary": { 14 | "title": "example glossary", 15 | "GlossDiv": { 16 | "integer": 1, 17 | "title": "S", 18 | "GlossList": { 19 | "GlossEntry": { 20 | "ID": "SGML", 21 | "SortAs": "SGML", 22 | "GlossTerm": "Standard Generalized Markup Language", 23 | "Acronym": "SGML", 24 | "Abbrev": "ISO 8879:1986", 25 | "GlossDef": { 26 | "para": "A meta-markup language, used to create markup languages such as DocBook.", 27 | "GlossSeeAlso": [ 28 | "GML", 29 | "XML" 30 | ] 31 | }, 32 | "GlossSee": "markup" 33 | } 34 | } 35 | } 36 | } 37 | }>> ; 38 | 39 | # parse data 40 | my $parsed = JSON::Tiny::Grammar.parse: $JSON ; 41 | 42 | # display using .perl 43 | #$parsed.perl.say ; 44 | 45 | # display using .gist 46 | $parsed.gist.say ; 47 | 48 | # show the dump via Data::Dump, this takes ages so it is commented out 49 | #use Data::Dump ; 50 | #Dump($parsed).say ; 51 | 52 | # dump with DDT 53 | my $d = Data::Dump::Tree.new: 54 | :title, 55 | #:!color, :width(100), :!display_info, 56 | :display_address(DDT_DISPLAY_NONE), 57 | :does(DDTR::MatchDetails, DDTR::PerlString, DDTR::Superscribe) ; 58 | 59 | # limit the output of the matched string to 40 characters in length 60 | $d.match_string_limit = 40 ; 61 | $d.ddt: $parsed ; 62 | 63 | $d.ddt: $parsed, :header_filters(&header_filter,), :elements_filters(&elements_filter,) ; 64 | 65 | sub header_filter($dumper, \r, $s, ($depth, $path, $glyph, @renderings), (\k, \b, \v, \f, \final, \want_address)) 66 | { 67 | # simplifying the dump, this is optional 68 | 69 | # with a value that has no sub elements can be displayed in a more compact way 70 | if k eq "" 71 | { 72 | my %caps = $s.caps ; 73 | 74 | if %caps.caps[0][0].key ~~ 'string' 75 | { 76 | v = ls(~%caps, 40) ~ ' => ' ~ ls(~%caps, 40) ; 77 | final = DDT_FINAL ; 78 | } 79 | } 80 | 81 | # "" | "" | "" | '' need no details 82 | if k eq "" | "" | "" | '' 83 | { 84 | v = '' ; 85 | f = '' ; 86 | } 87 | 88 | } 89 | 90 | sub elements_filter($dumper, $s, ($depth, $glyph, @renderings, $element), @sub_elements) 91 | { 92 | # simplifying the dump, this is optional 93 | 94 | my ($k, $b) = $element ; 95 | 96 | # matches will have two elements that add nothing to the dump, remove them 97 | @sub_elements = () if $k eq '' ; 98 | 99 | # has a element that add nothing to the dump; remove it 100 | @sub_elements = @sub_elements.grep({$_[0] ne '' }) if $k eq "" ; 101 | } 102 | 103 | 104 | # helper sub 105 | 106 | sub ls(Str $s, $limit) 107 | { 108 | if $limit.defined && $s.chars > $limit 109 | { 110 | $s.substr(0, $limit) ~ '(+' ~ $s.chars - $limit ~ ')' 111 | } 112 | else 113 | { 114 | $s 115 | } 116 | } 117 | 118 | 119 | -------------------------------------------------------------------------------- /examples/README.md: -------------------------------------------------------------------------------- 1 | Examples for Data::Dump::Tree 2 | ============================= 3 | 4 | - all.pl dump multiple type of elements and some filters examples 5 | 6 | - dhtml.pl create a DHTML file you can view in a browser 7 | 8 | - diff.pl diff between two data structures 9 | 10 | - ddt.pl example of adverbs used with ddt 11 | 12 | - remote/fold_send.pl sends an example folded data rendering to another process 13 | 14 | - remote/fold_receive.pl displays folded data rendering send by ddt_fold_send.pl 15 | 16 | - filter1.pl filter example 17 | 18 | - html.pl takes a DOM::Tiny parsing of google.com and renders the html 19 | 20 | - JSON_filter.pl compare json rendering to possible ddt rendering 21 | 22 | - jddt.pl reads json file and pretty prints it 23 | 24 | - jflat.pl reads json file and "flattens2 it, see data_source.pl 25 | 26 | - removal.pl remove elements from rendering with filters 27 | 28 | - folding.pl data structure folding 29 | 30 | - glyphs_color.pl different rendering of the glyphs 31 | 32 | - background_color.pl display elements with background color 33 | 34 | - highlight.pl how to highlight specific elements of the dump with colors 35 | 36 | - wrap_and_highlight.pl munge elements and also highlight them 37 | 38 | - custom_setup.pl extra dumper setup via a role 39 | 40 | - flat.pl horizontal layout examples 41 | 42 | - JSON_parsed.pl dump of the parsing of a JSON structure 43 | 44 | - junctions.pl dump of junctions 45 | 46 | - in32.pl NativeCall support examples 47 | 48 | - match.pl dump of a match object with different options 49 | 50 | - named_captures.pl dump of a regex match with named captures 51 | 52 | - named_elements.pl name specific elements and have the names displayed in the dump 53 | 54 | - paths.pl generating paths while dumping a data structure 55 | 56 | - sequences_pairs.pl dump of Seq and Pair 57 | 58 | - two_columns.pl display multiple columns of text, useful when you want to display multiple dumps 59 | 60 | - callframe.pl display a callframe and uses ddt_backtrace 61 | 62 | - data_source.pl "flattens" a tree and dumps it in a form more suitable for CLI manipulating 63 | 64 | -------------------------------------------------------------------------------- /examples/all.pl6: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env perl6 2 | 3 | use Data::Dump::Tree ; 4 | use Data::Dump::Tree::DescribeBaseObjects ; 5 | use Data::Dump::Tree::Enums ; 6 | 7 | # ------------------------------------------------------- 8 | # example with different types of elements and some roles 9 | # ------------------------------------------------------- 10 | 11 | class Strings 12 | { 13 | # a class that defines DDT specific methods 14 | 15 | method ddt_get_header { "say something about this class\nmultiline", '.' ~ self.^name ~ "\nmultiline classes" } 16 | 17 | method ddt_get_elements 18 | { 19 | ('', '', 'has no name'), 20 | ("very very long\nexplanation on multiple lines\n", '', "many lines\n" x 5), 21 | ('single-long', ': ', 'x' x 300), 22 | ('multiple-long', ': ', 'x' x 300 ~ "\n" ~ 'y' x 200), 23 | 24 | ('12345678901234567890123456789012345', '', [ 1, {a => 3} ]), 25 | ("12345678901234567890123456789012345\nxxx", '', 'test'), 26 | 27 | ('coefficient', ' = ', 1), 28 | } 29 | 30 | #class 31 | } 32 | 33 | # class with elements and methods but has not type handler nor DDT specific methods 34 | class GenericClass { has $.x ; has $!z ; method zz {} } 35 | role GenericRole { has $.role } 36 | role Whatnot { has $.whatnot is rw = 13 } 37 | 38 | # class with role that can be added to DDT 39 | class Dog { has $.name; } 40 | role DescribeDog 41 | { 42 | 43 | multi method get_header (Dog $d) 44 | { 45 | 'Woof! ', '.Dog (but this one is vagrant, no address)', DDT_NOT_FINAL, DDT_HAS_NO_ADDRESS 46 | } 47 | 48 | multi method get_elements (Dog $d) { (q/the dog's name is/, ': ', $d.name), } 49 | 50 | } 51 | 52 | 53 | # class with inheritance and with 2 different roles that can be added to DDT 54 | class Hermit {} 55 | class LivesUnderRock {} 56 | class Shy is Hermit is LivesUnderRock { has $.in_object } 57 | 58 | # hide all internals 59 | role DescribeShy { multi method get_elements (Shy $d) { } } 60 | 61 | #hide itself behind a scalar 62 | role DescribeShyFinal { multi method get_header (Shy $d) { 'Role{DescribeShyFinal} ', '.' ~ $d.^name, DDT_FINAL } } 63 | 64 | 65 | # class which returns computed "internal" representation 66 | class Mangled 67 | { 68 | method ddt_get_elements { ('inner structure', ' => ', [123, 456]), } 69 | } 70 | 71 | # class which returns a text representation, in the form of a table if Text::Table::Simple is installed 72 | class Table 73 | { 74 | 75 | has Str $!title = 'mail addresses:' ; 76 | has $!int = 1 ; 77 | 78 | method ddt_get_elements 79 | { 80 | my @e ; 81 | 82 | try 83 | { 84 | require Text::Table::Simple <&lol2table> ; 85 | 86 | my @columns = ; 87 | my @rows = ([1,"John Doe",'johndoe@cpan.org'], [2,'Jane Doe','mrsjanedoe@hushmail.com'],); 88 | my $table = lol2table(@columns, @rows).join("\n") ; 89 | 90 | # Add some fancy data rendering 91 | # on the left side row number 1..7, then 3 separate rendering side by side 92 | # DVO removes the type of the fancy rendering 93 | use Data::Dump::Tree::MultiColumns ; 94 | use Data::Dump::Tree::ExtraRoles ; 95 | 96 | my $element = [1, [2, [3, 4]]] ; 97 | my @data = $element, ([6, [3]],), $element ; 98 | 99 | my $columns = get_columns (1..7), |(@data.map({ get_dump_lines_integrated $_, :does[DDTR::Superscribe] })) ; 100 | 101 | @e = ($!title, '', $table), ('fancy table data', ':', DVO($columns)), |get_attributes(self), ; 102 | } 103 | 104 | $! ?? (('DDT exception', ': ', "$!"),) !! @e ; 105 | } 106 | 107 | #class 108 | } 109 | 110 | # ------------- test -------------- 111 | 112 | ddt 113 | get_test_structure(), 114 | :title, 115 | :caller, 116 | :display_perl_address, 117 | :width(75), 118 | :does[DescribeDog, DescribeShyFinal], #DescribeShy 119 | :max_depth(3) ; 120 | 121 | # ------------- helpers ------------- 122 | 123 | sub get_test_structure 124 | { 125 | my $nil is default(Nil) = Nil; 126 | my @a = 1 ; 127 | my $b = [< a >] ; 128 | my $list = < a b > ; 129 | my $sub = sub (Int $a, Str $string) {} 130 | my Routine $routine ; 131 | 132 | my $s = [ 133 | 'text', 134 | Str, 135 | 12, 136 | Int, 137 | Rat.new(31, 10), 138 | $sub, 139 | $routine, 140 | [], 141 | @a, 142 | $b, 143 | @a, 144 | $b, 145 | $list, 146 | { 147 | default_nil => $nil, 148 | Nil => Nil, 149 | a => 1, 150 | b => 'string', 151 | }, 152 | Cool.new(), 153 | Table.new(), 154 | (GenericClass.new(:x(5), :z('hi there')) does GenericRole) but Whatnot, 155 | Mangled.new(), 156 | Dog.new(name => 'fido'), 157 | Shy.new(secret => 'I will not say'), 158 | Strings.new(), 159 | #regex 160 | 'aaa' ~~ m:g/(a)/, 161 | ] ; 162 | 163 | $s ; 164 | } 165 | 166 | 167 | -------------------------------------------------------------------------------- /examples/all_color_blob.pl6: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env perl6 2 | 3 | use Data::Dump::Tree ; 4 | use Data::Dump::Tree::DescribeBaseObjects ; 5 | use Data::Dump::Tree::Enums ; 6 | 7 | # ------------------------------------------------------- 8 | # example with different types of elements and some roles 9 | # ------------------------------------------------------- 10 | 11 | class Strings 12 | { 13 | # a class that defines DDT specific methods 14 | 15 | method ddt_get_header { "say something about this class\nmultiline", '.' ~ self.^name ~ "\nmultiline classes" } 16 | 17 | method ddt_get_elements 18 | { 19 | ('', '', 'has no name'), 20 | ("very very long\nexplanation on multiple lines\n", '', "many lines\n" x 5), 21 | ('single-long', ': ', 'x' x 300), 22 | ('multiple-long', ': ', 'x' x 300 ~ "\n" ~ 'y' x 200), 23 | 24 | ('12345678901234567890123456789012345', '', [ 1, {a => 3} ]), 25 | ("12345678901234567890123456789012345\nxxx", '', 'test'), 26 | 27 | ('coefficient', ' = ', 1), 28 | } 29 | 30 | #class 31 | } 32 | 33 | # class with elements and methods but has not type handler nor DDT specific methods 34 | class GenericClass { has $.x ; has $!z ; method zz {} } 35 | role GenericRole { has $.role } 36 | role Whatnot { has $.whatnot is rw = 13 } 37 | 38 | # class with role that can be added to DDT 39 | class Dog { has $.name; } 40 | role DescribeDog 41 | { 42 | 43 | multi method get_header (Dog $d) 44 | { 45 | 'Woof! ', '.Dog (but this one is vagrant, no address)', DDT_NOT_FINAL, DDT_HAS_NO_ADDRESS 46 | } 47 | 48 | multi method get_elements (Dog $d) { (q/the dog's name is/, ': ', $d.name), } 49 | 50 | } 51 | 52 | 53 | # class with inheritance and with 2 different roles that can be added to DDT 54 | class Hermit {} 55 | class LivesUnderRock {} 56 | class Shy is Hermit is LivesUnderRock { has $.in_object } 57 | 58 | # hide all internals 59 | role DescribeShy { multi method get_elements (Shy $d) { } } 60 | 61 | #hide itself behind a scalar 62 | role DescribeShyFinal { multi method get_header (Shy $d) { 'Role{DescribeShyFinal} ', '.' ~ $d.^name, DDT_FINAL } } 63 | 64 | 65 | # class which returns computed "internal" representation 66 | class Mangled 67 | { 68 | method ddt_get_elements { ('inner structure', ' => ', [123, 456]), } 69 | } 70 | 71 | # class which returns a text representation, in the form of a table if Text::Table::Simple is installed 72 | class Table 73 | { 74 | 75 | has Str $!title = 'mail addresses:' ; 76 | has $!int = 1 ; 77 | 78 | method ddt_get_elements 79 | { 80 | my @e ; 81 | 82 | try 83 | { 84 | require Text::Table::Simple <&lol2table> ; 85 | 86 | my @columns = ; 87 | my @rows = ([1,"John Doe",'johndoe@cpan.org'], [2,'Jane Doe','mrsjanedoe@hushmail.com'],); 88 | my $table = lol2table(@columns, @rows).join("\n") ; 89 | 90 | # Add some fancy data rendering 91 | # on the left side row number 1..7, then 3 separate rendering side by side 92 | # DVO removes the type of the fancy rendering 93 | use Data::Dump::Tree::MultiColumns ; 94 | use Data::Dump::Tree::ExtraRoles ; 95 | 96 | my $element = [1, [2, [3, 4]]] ; 97 | my @data = $element, ([6, [3]],), $element ; 98 | 99 | my $columns = get_columns (1..7), |(@data.map({ get_dump_lines_integrated $_, :does[DDTR::Superscribe] })) ; 100 | 101 | @e = ($!title, '', $table), ('fancy table data', ':', DVO($columns)), |get_attributes(self), ; 102 | } 103 | 104 | $! ?? (('DDT exception', ': ', "$!"),) !! @e ; 105 | } 106 | 107 | #class 108 | } 109 | 110 | # ------------- test -------------- 111 | 112 | use Terminal::ANSIColor ; 113 | my @colors = < on_22 on_17 on_20 on_52 on_56 on_92 > ; 114 | my $color_filter_type = 1 ; 115 | 116 | ddt 117 | get_test_structure(), 118 | :title, 119 | :caller, 120 | :display_perl_address, 121 | :width(75), 122 | :does[DescribeDog, DescribeShyFinal], #DescribeShy 123 | :max_depth(3) ; 124 | 125 | ddt 126 | get_test_structure(), 127 | :title, 128 | :!color, 129 | :glyph_filters[&color_background], 130 | :caller, 131 | :display_perl_address, 132 | :width(75), 133 | :does[DescribeDog, DescribeShyFinal], #DescribeShy 134 | :max_depth(3) ; 135 | 136 | multi sub color_background($dumper, $s, $depth, $path, $key, @glyphs, @reset_color) 137 | { 138 | my $color = '' ; 139 | 140 | if $color_filter_type == 1 141 | { 142 | $color = color(@colors[$depth % @colors.elems]) ; 143 | } 144 | elsif $color_filter_type == 2 145 | { 146 | # level colored as previous level 147 | if $depth != 2 | 3 | 5 148 | { 149 | $color = color(@colors[$depth % @colors.elems]) ; 150 | } 151 | } 152 | else 153 | { 154 | if $depth == 2 || $depth > 5 155 | { 156 | $color = color(@colors[$depth % @colors.elems]) ; 157 | } 158 | else 159 | { 160 | $color = color('reset') ; 161 | } 162 | } 163 | 164 | @reset_color.push: (color('reset'), '' , '') ; 165 | 166 | my ($glyph_width, $glyph, $continuation_glyph, $multi_line_glyph, $empty_glyph, $filter_glyph) = @glyphs ; 167 | 168 | $glyph = ($color, |$glyph[1..2]) ; 169 | $continuation_glyph = ($color, |$continuation_glyph[1..2]) ; 170 | $multi_line_glyph = ($color, |$multi_line_glyph[1..2]) ; 171 | $empty_glyph = ($color, |$empty_glyph[1..2]) ; 172 | $filter_glyph = ($color, |$filter_glyph[1..2]) ; 173 | 174 | @glyphs = ($glyph_width, $glyph, $continuation_glyph, $multi_line_glyph, $empty_glyph, $filter_glyph) ; 175 | } 176 | # ------------- helpers ------------- 177 | 178 | sub get_test_structure 179 | { 180 | my $nil is default(Nil) = Nil; 181 | my @a = 1 ; 182 | my $b = [< a >] ; 183 | my $list = < a b > ; 184 | my $sub = sub (Int $a, Str $string) {} 185 | my Routine $routine ; 186 | 187 | my $s = [ 188 | 'text', 189 | Str, 190 | 12, 191 | Int, 192 | Rat.new(31, 10), 193 | $sub, 194 | $routine, 195 | [], 196 | @a, 197 | $b, 198 | @a, 199 | $b, 200 | $list, 201 | { 202 | default_nil => $nil, 203 | Nil => Nil, 204 | a => 1, 205 | b => 'string', 206 | }, 207 | Cool.new(), 208 | Table.new(), 209 | (GenericClass.new(:x(5), :z('hi there')) does GenericRole) but Whatnot, 210 | Mangled.new(), 211 | Dog.new(name => 'fido'), 212 | Shy.new(secret => 'I will not say'), 213 | Strings.new(), 214 | #regex 215 | 'aaa' ~~ m:g/(a)/, 216 | ] ; 217 | 218 | $s ; 219 | } 220 | 221 | 222 | -------------------------------------------------------------------------------- /examples/all_folding.pl6: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env perl6 2 | 3 | use Data::Dump::Tree ; 4 | use Data::Dump::Tree::DescribeBaseObjects ; 5 | use Data::Dump::Tree::Enums ; 6 | 7 | # ------------------------------------------------------- 8 | # example with different types of elements and some roles 9 | # ------------------------------------------------------- 10 | 11 | class Strings 12 | { 13 | # a class that defines DDT specific methods 14 | 15 | method ddt_get_header { "say something about this class\nmultiline", '.' ~ self.^name ~ "\nmultiline classes" } 16 | 17 | method ddt_get_elements 18 | { 19 | ('', '', 'has no name'), 20 | ("very very long\nexplanation on multiple lines\n", '', "many lines\n" x 5), 21 | ('single-long', ': ', 'x' x 300), 22 | ('multiple-long', ': ', 'x' x 300 ~ "\n" ~ 'y' x 200), 23 | 24 | ('12345678901234567890123456789012345', '', [ 1, {a => 3} ]), 25 | ("12345678901234567890123456789012345\nxxx", '', 'test'), 26 | 27 | ('coefficient', ' = ', 1), 28 | } 29 | 30 | #class 31 | } 32 | 33 | # class with elements and methods but has not type handler nor DDT specific methods 34 | class GenericClass { has $.x ; has $!z ; method zz {} } 35 | role GenericRole { has $.role } 36 | role Whatnot { has $.whatnot is rw = 13 } 37 | 38 | # class with role that can be added to DDT 39 | class Dog { has $.name; } 40 | role DescribeDog 41 | { 42 | 43 | multi method get_header (Dog $d) 44 | { 45 | 'Woof! ', '.Dog (but this one is vagrant, no address)', DDT_NOT_FINAL, DDT_HAS_NO_ADDRESS 46 | } 47 | 48 | multi method get_elements (Dog $d) { (q/the dog's name is/, ': ', $d.name), } 49 | 50 | } 51 | 52 | 53 | # class with inheritance and with 2 different roles that can be added to DDT 54 | class Hermit {} 55 | class LivesUnderRock {} 56 | class Shy is Hermit is LivesUnderRock { has $.in_object } 57 | 58 | # hide all internals 59 | role DescribeShy { multi method get_elements (Shy $d) { } } 60 | 61 | #hide itself behind a scalar 62 | role DescribeShyFinal { multi method get_header (Shy $d) { 'Role{DescribeShyFinal} ', '.' ~ $d.^name, DDT_FINAL } } 63 | 64 | 65 | # class which returns computed "internal" representation 66 | class Mangled 67 | { 68 | method ddt_get_elements { ('inner structure', ' => ', [123, 456]), } 69 | } 70 | 71 | # class which returns a text representation, in the form of a table if Text::Table::Simple is installed 72 | class Table 73 | { 74 | 75 | has Str $!title = 'mail addresses:' ; 76 | has $!int = 1 ; 77 | 78 | method ddt_get_elements 79 | { 80 | my @e ; 81 | 82 | try 83 | { 84 | require Text::Table::Simple <&lol2table> ; 85 | 86 | my @columns = ; 87 | my @rows = ([1,"John Doe",'johndoe@cpan.org'], [2,'Jane Doe','mrsjanedoe@hushmail.com'],); 88 | my $table = lol2table(@columns, @rows).join("\n") ; 89 | 90 | use Data::Dump::Tree::MultiColumns ; 91 | 92 | my $element = [1, [2, [3, 4]]] ; 93 | my $data = [ $element, ([6, [3]],), $element ] ; 94 | 95 | #my $columns = get_columns (1..7), |($data.map({ get_dump_lines_integrated($_) })) ; 96 | my $columns = '' ; 97 | 98 | @e = ($!title, '', $table ~ "\n" ~ $columns), |get_attributes(self), ; 99 | } 100 | 101 | $! ?? (('DDT exception', ': ', "$!"),) !! @e ; 102 | } 103 | 104 | #class 105 | } 106 | 107 | # ------------- test -------------- 108 | 109 | sub MAIN(Bool :$debug) 110 | { 111 | ddt 112 | get_test_structure(), 113 | :fold, 114 | :$debug, 115 | :title, 116 | :caller, 117 | :display_perl_address, 118 | :width(75), 119 | :does[DescribeDog, DescribeShyFinal], 120 | :max_depth(3), 121 | ; 122 | } 123 | 124 | # ------------- helpers ------------- 125 | 126 | sub get_test_structure 127 | { 128 | my $nil is default(Nil) = Nil; 129 | my @a = 1 ; 130 | my $b = [< a >] ; 131 | my $list = < a b > ; 132 | my $sub = sub (Int $a, Str $string) {} 133 | my Routine $routine ; 134 | 135 | my $s = [ 136 | 'text', 137 | Str, 138 | 12, 139 | Int, 140 | Rat.new(31, 10), 141 | $sub, 142 | $routine, 143 | [], 144 | @a, 145 | $b, 146 | @a, 147 | $b, 148 | $list, 149 | { 150 | default_nil => $nil, 151 | Nil => Nil, 152 | a => 1, 153 | b => 'string', 154 | }, 155 | Cool.new(), 156 | Table.new(), 157 | (GenericClass.new(:x(5), :z('hi there')) does GenericRole) but Whatnot, 158 | Mangled.new(), 159 | Dog.new(name => 'fido'), 160 | Shy.new(secret => 'I will not say'), 161 | Strings.new(), 162 | #regex 163 | 'aaa' ~~ m:g/(a)/, 164 | ] ; 165 | 166 | $s ; 167 | } 168 | 169 | 170 | -------------------------------------------------------------------------------- /examples/background_color.pl6: -------------------------------------------------------------------------------- 1 | 2 | use Data::Dump::Tree ; 3 | use Data::Dump::Tree::Enums ; 4 | use Data::Dump::Tree::ExtraRoles ; 5 | 6 | use Terminal::ANSIColor ; 7 | use JSON::Tiny ; 8 | 9 | my $main_glossary = 10 | Q<< 11 | "Gloss 2": { 12 | "integer": 1, 13 | "title": "S", 14 | "GlossList": { 15 | "GlossEntry": { 16 | "ID": "SGML", 17 | "SortAs": "SGML", 18 | "GlossTerm": "Standard Generalized Markup Language", 19 | "Acronym": "SGML", 20 | "Abbrev": "ISO 8879:1986", 21 | "GlossDef": { 22 | "para": "A meta-markup language, used to create markup languages such as DocBook.", 23 | "GlossSeeAlso": [ 24 | "GML", 25 | "XML" 26 | ] 27 | }, 28 | "GlossSee": "markup" 29 | } 30 | } 31 | } 32 | >> ; 33 | 34 | my $JSON_ONE_GLOSSARY = 35 | Q<<{ 36 | "glossary": { 37 | "title": "example glossary", 38 | >> 39 | ~ "$main_glossary" ~ 40 | Q<< 41 | } 42 | }>> ; 43 | 44 | my $JSON = 45 | Q<<{ 46 | "glossary": { 47 | "title": "example glossary", 48 | "Gloss 1": { 49 | "integer": 1 50 | }, 51 | >> 52 | ~ "$main_glossary," ~ 53 | Q<< 54 | "Gloss 3": { 55 | "integer": 1 56 | } 57 | } 58 | }>> ; 59 | 60 | my @colors = < on_22 on_17 on_20 on_52 on_56 on_92 on_127> ; 61 | 62 | my $d = Data::Dump::Tree.new: 63 | :title, 64 | :!color, 65 | :display_information(DDT_DISPLAY_NONE), 66 | :width(Inf) ; 67 | 68 | my $color_filter_type ; 69 | 70 | for 1 -> $type 71 | { 72 | $color_filter_type = $type ; 73 | $d.ddt: from-json($JSON_ONE_GLOSSARY), 74 | :does[DDTR::FixedGlyphs], 75 | :glyph_filters[&color_background], 76 | :nl ; 77 | 78 | $d.ddt: from-json($JSON_ONE_GLOSSARY), 79 | :does[DDTR::FixedGlyphs], 80 | :glyph_filters[&color_background], 81 | :elements_filters[&final_first, &non_final_no_binder, &align_keys], 82 | :nl ; 83 | } 84 | 85 | for 1..3 -> $type 86 | { 87 | $color_filter_type = $type ; 88 | $d.ddt: from-json($JSON), 89 | :does[DDTR::FixedGlyphs], 90 | :glyph_filters[&color_background], 91 | :nl ; 92 | 93 | $d.ddt: from-json($JSON), 94 | :does[DDTR::FixedGlyphs], 95 | :glyph_filters[&color_background], 96 | :elements_filters[&final_first, &non_final_no_binder, &align_keys], 97 | :nl ; 98 | } 99 | 100 | $color_filter_type = 3 ; 101 | $d.ddt: from-json($JSON), :color, :color_filters[&color_background], :nl ; 102 | 103 | $d.ddt: from-json($JSON), 104 | :color, 105 | :glyph_filters[&color_background], 106 | :!display_type, 107 | :elements_filters[&final_first, &non_final_no_binder, &align_keys] ; 108 | 109 | multi sub color_background($dumper, $s, $depth, $path, $key, @glyphs, @reset_color) 110 | { 111 | my $color = '' ; 112 | 113 | if $color_filter_type == 1 114 | { 115 | $color = color(@colors[$depth % @colors.elems]) ; 116 | } 117 | elsif $color_filter_type == 2 118 | { 119 | # level colored as previous level 120 | if $depth != 2 | 3 | 5 121 | { 122 | $color = color(@colors[$depth % @colors.elems]) ; 123 | } 124 | } 125 | else 126 | { 127 | if $depth == 2 || $depth > 5 128 | { 129 | $color = color(@colors[$depth % @colors.elems]) ; 130 | } 131 | else 132 | { 133 | $color = color('reset') ; 134 | } 135 | } 136 | 137 | @reset_color.push: (color('reset'), '' , '') ; 138 | 139 | my ($glyph_width, $glyph, $continuation_glyph, $multi_line_glyph, $empty_glyph, $filter_glyph) = @glyphs ; 140 | 141 | $glyph = ($color, |$glyph[1..2]) ; 142 | $continuation_glyph = ($color, |$continuation_glyph[1..2]) ; 143 | $multi_line_glyph = ($color, |$multi_line_glyph[1..2]) ; 144 | $empty_glyph = ($color, |$empty_glyph[1..2]) ; 145 | $filter_glyph = ($color, |$filter_glyph[1..2]) ; 146 | 147 | @glyphs = ($glyph_width, $glyph, $continuation_glyph, $multi_line_glyph, $empty_glyph, $filter_glyph) ; 148 | } 149 | 150 | multi sub final_first($dumper, $, $, @sub_elements) 151 | { 152 | @sub_elements = @sub_elements.sort: { $dumper.get_element_header($^a[2])[2] !~~ DDT_FINAL } 153 | } 154 | 155 | multi sub non_final_no_binder ($dumper, $, $, @sub_elements) 156 | { 157 | for @sub_elements -> ($k, $binder is rw, $value, $) 158 | { 159 | $binder = '' if $dumper.get_element_header($value)[2] !~~ DDT_FINAL ; 160 | } 161 | } 162 | 163 | multi sub align_keys ($dumper, $, $, @sub_elements) 164 | { 165 | my $max_kb = ( my @cache = @sub_elements.map: { (.[0] ~ .[1]).chars }).max ; 166 | 167 | for @sub_elements Z @cache -> (@e, $l) { @e[0] ~= ' ' x $max_kb - $l } 168 | } 169 | 170 | 171 | -------------------------------------------------------------------------------- /examples/but.pl6: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env perl6 2 | 3 | use Data::Dump::Tree ; 4 | use Data::Dump::Tree::Enums ; 5 | 6 | role my_role { has $.something is rw } # test that Int+something type displays correctly 7 | 8 | my $my_role = my_role.new(:something) ; 9 | 10 | my $i = IntStr.new(7, 'but more') but my_role ; 11 | $i.something = "set to something" ; 12 | 13 | my $data = 14 | [ 15 | 1, 16 | IntStr.new(2, '2'), 17 | IntStr.new(3, 'three'), 18 | IntStr.new(4, 'but more') but my_role, 19 | IntStr.new(5, 'but more') but my_role.new(:something), 20 | IntStr.new(6, 'but more') but $my_role, 21 | $i, 22 | my_role, 23 | $my_role, 24 | ] ; 25 | 26 | ddt $data, :nl ; 27 | 28 | #more examples, specially the one demonstrating that assigning to an 29 | # @array does just that, so do not @ = @+role, use binding or scalars 30 | 31 | my role MaxLines { has $.max_lines is rw = 0 } 32 | 33 | my @a = [1..2] ; 34 | my $current_block = [1..2] but MaxLines ; 35 | my @b = [1..3] but MaxLines ; 36 | my $b = @a but MaxLines ; 37 | my @b_bind := [1..3] but MaxLines ; 38 | @b_bind.max_lines = 7 ; 39 | 40 | my @c = @a but MaxLines ; 41 | 42 | my @d2 does MaxLines = [1..2] ; 43 | @d2.max_lines = 1 ; 44 | 45 | my @d22 = @b_bind ; 46 | my @d33 := @b_bind ; 47 | 48 | my @d3 does MaxLines = @b_bind ; 49 | my @d4 does MaxLines = [1..2] ; 50 | 51 | ddt :flat(0), (@a, $current_block, @b, $b, @b_bind, @c, @d2, @d22, @d33, @d3, @d4) ; 52 | 53 | ddt :flat(0), 54 | [ 55 | [1..2], 56 | [1..3], 57 | ] ; 58 | 59 | ddt 60 | [ 61 | '@a = [1..2]' => @a, 62 | '$current_block = [1..2] but MaxLines' => $current_block, 63 | '@b = [1..3] but MaxLines' => @b, 64 | ] ; 65 | 66 | ddt :flat(0), 67 | [ 68 | '@a = [1..2]' => @a, 69 | '$current_block = [1..2] but MaxLines' => $current_block, 70 | ] ; 71 | 72 | ddt :flat(0), 73 | [ 74 | '@a = [1..2]' => @a, 75 | '$current_block = [1..2] but MaxLines' => $current_block, 76 | '@b = [1..3] but MaxLines' => @b, 77 | '$b = @a but MaxLines' => $b, 78 | '@b_bind := [1..3] but MaxLines; max_lines = 7' => @b_bind, 79 | '@c = @a but MaxLines' => @c, 80 | '@d2 does MaxLines = [1..2], max_lines = 1' => @d2, 81 | '@d22 = @b_bind' => @d22, 82 | '@d33 := @b_bind' => @d33, 83 | '@d3 does MaxLines = @b_bind' => @d3, 84 | '@d4 does MaxLines = [1..2]' => @d4, 85 | ] ; 86 | -------------------------------------------------------------------------------- /examples/caller_name_title.pl6: -------------------------------------------------------------------------------- 1 | use Data::Dump::Tree ; 2 | use Data::Dump::Tree::DescribeBaseObjects ; 3 | use Terminal::ANSIColor ; 4 | 5 | my $d = Data::Dump::Tree.new: :caller ; 6 | $d.ddt ; 7 | ddt ; 8 | 9 | dd [0..1] ; 10 | ddt [1..2] ; 11 | ddt [2..3], :title ; 12 | 13 | $d.ddt: [3..4] ; 14 | ddt [4..5], :caller ; 15 | ddt [5..6], :caller, :title<title> ; 16 | 17 | my @a = [6..7] ; 18 | 19 | ddt @a, :caller ; 20 | ddt @a, :title<title> ; 21 | 22 | ddt True, @a, :caller; 23 | ddt True, @a, :title<title> ; 24 | 25 | my Int $int = 3 ; 26 | dd $int ; 27 | ddt $int ; 28 | 29 | -------------------------------------------------------------------------------- /examples/callframe.pl6: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env perl6 2 | 3 | unit module XYZ ; 4 | 5 | use Data::Dump::Tree ; 6 | use Data::Dump::Tree::Enums ; 7 | 8 | ddt_backtrace ; 9 | my $ddt = Data::Dump::Tree.new ; 10 | 11 | dd callframe() ; 12 | ddt callframe() ; 13 | 14 | role NoForeignCode 15 | { 16 | multi method get_header (ForeignCode $fc) 17 | { 18 | '', '.' ~ $fc.^name, DDT_FINAL 19 | } 20 | } 21 | 22 | ddt Backtrace.new.list, :title<Backtrace>, :does[NoForeignCode] ; 23 | 24 | -------------------------------------------------------------------------------- /examples/custom_setup.pl6: -------------------------------------------------------------------------------- 1 | 2 | use Data::Dump::Tree ; 3 | 4 | # use a module that's located in the examples directory 5 | require ($*PROGRAM.parent(1).absolute ~ "/CustomSetup/CustomSetup.pm") <CustomSetup> ; 6 | 7 | my regex identifier { \w+ } 8 | my regex kvpair { \s* <key=identifier> '=' <value=identifier> } 9 | 10 | ddt "jack=password1" ~~ /<kvpair>*/, :title<key-value>, :does[CustomSetup] ; 11 | 12 | -------------------------------------------------------------------------------- /examples/data_source.pl6: -------------------------------------------------------------------------------- 1 | 2 | use Data::Dump::Tree ; 3 | use JSON::Tiny ; 4 | 5 | my $JSON = 6 | Q<<{ 7 | "glossary": { 8 | "title": "example glossary" 9 | } 10 | }>> ; 11 | 12 | my $parsed = JSON::Tiny::Grammar.parse: $JSON ; 13 | 14 | # use a module that's located in the examples directory 15 | require ($*PROGRAM.parent(1).absolute ~ "/CustomSetup/DataSource.pm6") <DataSource> ; 16 | 17 | use Data::Dump::Tree::ExtraRoles ; 18 | ddt $parsed, :title<JSON >, :does[DDTR::PerlString,DDTR::MatchDetails] ; 19 | ddt $parsed, :title<JSON >, :!color, :does[DataSource, DDTR::PerlString,DDTR::MatchDetails] ; 20 | 21 | ddt [1, 2, [ 3, 4, [Str],], {a => 1}, (a => [1, 2])], :title<struct> ; 22 | ddt [1, 2, [ 3, 4, [Str],], {a => 1}, (a => [1, 2])], :title<struct>, :!color, :does[DataSource] ; 23 | 24 | # following line fixed (believe it or not) error: 25 | # Cannot mix in non-composable type Any into object of type Data::Dump::Tree 26 | # which happens during the ddt call ... above! 27 | # bug report https://github.com/rakudo/rakudo/issues/2983 28 | my regex {1} 29 | 30 | -------------------------------------------------------------------------------- /examples/ddt.pl6: -------------------------------------------------------------------------------- 1 | use Data::Dump::Tree ; 2 | use Data::Dump::Tree::Ddt ; # for ddt_remote 3 | 4 | my $s = [1, [1, [1..2]]] ; 5 | 6 | ddt :title<no adverb>, $s ; 7 | ddt :title<:print>, $s, :print ; 8 | ddt ddt(:title<:get>, $s, :get) ; 9 | ddt ddt(:title<:get_lines>, $s, :get_lines) ; 10 | ddt ddt(:title<:get_lines-integrated>, $s, :get_lines_integrated) ; 11 | ddt :title<:fold>, $s, :fold ; 12 | ddt :title<:remote>, $s, :remote ; 13 | ddt :title<:remote_fold>, $s, :remote_fold ; 14 | 15 | my $d = DDT :!color ; 16 | 17 | $d.ddt: :title<no adverb>, $s ; 18 | $d.ddt: :title<:print>, $s, :print ; 19 | ddt $d.ddt(:title<:get>, $s, :get) ; 20 | ddt $d.ddt(:title<:get_lines>, $s, :get_lines) ; 21 | ddt $d.ddt(:title<:get_lines-integrated>, $s, :get_lines_integrated) ; 22 | $d.ddt: :title<:fold>, $s, :fold ; 23 | $d.ddt: :title<:remote>, $s, :remote, :remote_port(1234) ; 24 | $d.ddt: :title<:remote_fold>, $s, :remote_fold ; 25 | 26 | ddt_remote "ddt_remote" ; 27 | 28 | -------------------------------------------------------------------------------- /examples/dhtml.pl6: -------------------------------------------------------------------------------- 1 | 2 | use Data::Dump::Tree ; 3 | use Data::Dump::Tree::Enums ; 4 | use Data::Dump::Tree::DescribeBaseObjects ; 5 | use Data::Dump::Tree::ExtraRoles ; 6 | use Data::Dump::Tree::DHTML; 7 | 8 | my $d1 = Data::Dump::Tree.new(title => 'Config', does => ( DDTR::DHTML,),) ; 9 | 10 | my regex header { \s* '[' (\w+) ']' \h* \n+ } 11 | my regex identifier { \w+ } 12 | my regex kvpair { \s* <key=identifier> '=' <value=identifier> \n+ } 13 | my regex section { 14 | <header> 15 | <kvpair>* 16 | } 17 | 18 | my $config = q:to/EOI/; 19 | [passwords] 20 | jack=password1 21 | joy=muchmoresecure123 22 | [quotas] 23 | jack=123 24 | joy=42 25 | EOI 26 | 27 | $d1 does DDTR::MatchDetails ; 28 | 29 | $d1.dump_dhtml: $config ~~ /<section>*/ ; 30 | note $d1.get_dump: $config ~~ /<section>*/ ; 31 | 32 | # use json parser 33 | use JSON::Tiny ; 34 | 35 | # The Json that needs parsing 36 | my $JSON = 37 | Q<<{ 38 | "glossary": { 39 | "title": "example glossary", 40 | "GlossDiv": { 41 | "title": "S", 42 | "GlossList": { 43 | "GlossEntry": { 44 | "ID": "SGML", 45 | "SortAs": "SGML", 46 | "GlossTerm": "Standard Generalized Markup Language", 47 | "Acronym": "SGML", 48 | "Abbrev": "ISO 8879:1986", 49 | "GlossDef": { 50 | "para": "A meta-markup language, used to create markup languages such as DocBook.", 51 | "GlossSeeAlso": ["GML", "XML"] 52 | }, 53 | "GlossSee": "markup" 54 | } 55 | } 56 | } 57 | } 58 | }>> ; 59 | 60 | # parse data 61 | my $parsed = JSON::Tiny::Grammar.parse($JSON) ; 62 | 63 | my $d = Data::Dump::Tree.new: 64 | :title<Parsed JSON>, 65 | :does(DDTR::DHTML, DDTR::MatchDetails, DDTR::PerlString), 66 | :display_address(DDT_DISPLAY_NONE) ; 67 | 68 | # limit the output of the matched string to 40 characters in length 69 | $d.match_string_limit = 40 ; 70 | 71 | $d.dump_dhtml: $parsed ; 72 | $d.ddt: :note, $parsed ; 73 | 74 | 75 | 76 | class Strings 77 | { 78 | # a class that defines DDT specific methods 79 | 80 | method ddt_get_header { "say something about this class\nmultiline", '.' ~ self.^name ~ "\n multiline classes" } 81 | 82 | method ddt_get_elements 83 | { 84 | ('', '', 'has no name'), 85 | ("very very long\nexplanation on multiple lines\n", '', "many lines\n" x 5), 86 | ('single-long', ': ', 'x' x 300), 87 | ('multiple-long', ': ', 'x' x 300 ~ "\n" ~ 'y' x 200), 88 | 89 | ('12345678901234567890123456789012345', '', [ 1, {a => 3} ]), 90 | ("12345678901234567890123456789012345\nxxx", '', 'test'), 91 | 92 | ('coefficient', ' = ', 1), 93 | } 94 | 95 | #class 96 | } 97 | 98 | # class with elements and methods but has not type handler nor DDT specific methods 99 | class GenericClass { has $.x ; has $!z ; method zz {} } 100 | 101 | # class with role that can be added to DDT 102 | class Dog { has $.name; } 103 | role DescribeDog 104 | { 105 | 106 | multi method get_header (Dog $d) 107 | { 108 | 'Woof! ', '.Dog (but this one is vagrant, no address)', DDT_NOT_FINAL, DDT_HAS_NO_ADDRESS 109 | } 110 | 111 | multi method get_elements (Dog $d) { (q/the dog's name is/, ': ', $d.name), } 112 | 113 | } 114 | 115 | 116 | # class with inheritance and with 2 different roles that can be added to DDT 117 | class Hermit {} 118 | class LivesUnderRock {} 119 | class Shy is Hermit is LivesUnderRock { has $.in_object } 120 | 121 | # hide all internals 122 | role DescribeShy { multi method get_elements (Shy $d) { } } 123 | 124 | #hide itself behind a scalar 125 | role DescribeShyFinal { multi method get_header (Shy $d) { 'Role{DescribeShyFinal} ', '.' ~ $d.^name, DDT_FINAL } } 126 | 127 | # class which returns computed "internal" representation 128 | class Mangled 129 | { 130 | method ddt_get_elements { ('inner structure', ' => ', [123, 456]), } 131 | } 132 | 133 | # class which returns a text representation, in the form of a table if Text::Table::Simple is installed 134 | class Table 135 | { 136 | 137 | has Str $!title = 'mail addresses:' ; 138 | has $!int = 1 ; 139 | 140 | method ddt_get_elements 141 | { 142 | my @e ; 143 | 144 | try 145 | { 146 | require Text::Table::Simple <&lol2table> ; 147 | 148 | my @columns = <id name email>; 149 | my @rows = ([1,"John Doe",'johndoe@cpan.org'], [2,'Jane Doe','mrsjanedoe@hushmail.com'],); 150 | my @table = lol2table(@columns,@rows); 151 | 152 | @e = ($!title, '', @table.join("\n")), |get_attributes(self), ; 153 | } 154 | 155 | $! ?? (('DDT exception', ': ', "$!"),) !! @e ; 156 | } 157 | 158 | #class 159 | } 160 | 161 | # ------------- test -------------- 162 | 163 | my $dall = Data::Dump::Tree.new: 164 | :title<test data>, 165 | :does(DDTR::DHTML, DDTR::MatchDetails, DescribeDog, DescribeShyFinal), 166 | :caller, 167 | :display_perl_address, 168 | :width(75), 169 | :max_depth(3) ; 170 | 171 | $dall.dump_dhtml: get_test_structure ; 172 | $dall.ddt: :note, get_test_structure ; 173 | 174 | # ------------- helpers ------------- 175 | 176 | sub get_test_structure 177 | { 178 | my $nil is default(Nil) = Nil; 179 | my @a = 1 ; 180 | my $b = [< a >] ; 181 | my $list = < a b > ; 182 | my $sub = sub (Int $a, Str $string) {} 183 | my Routine $routine ; 184 | 185 | my $s = [ 186 | 'text', 187 | Str, 188 | 12, 189 | Int, 190 | Rat.new(31, 10), 191 | $sub, 192 | $routine, 193 | [], 194 | @a, 195 | $b, 196 | @a, 197 | $b, 198 | $list, 199 | { 200 | default_nil => $nil, 201 | Nil => Nil, 202 | a => 1, 203 | b => 'string', 204 | }, 205 | Cool.new(), 206 | Table.new(), 207 | GenericClass.new(:x(5), :z('hi there')), 208 | Mangled.new(), 209 | Dog.new(name => 'fido'), 210 | Shy.new(secret => 'I will not say'), 211 | Strings.new(), 212 | #regex 213 | 'aaa' ~~ m:g/(a)/, 214 | ] ; 215 | 216 | $s ; 217 | } 218 | 219 | 220 | 221 | -------------------------------------------------------------------------------- /examples/diff.pl6: -------------------------------------------------------------------------------- 1 | 2 | use Data::Dump::Tree ; 3 | 4 | # get role to show diff 5 | use Data::Dump::Tree::Diff ; 6 | 7 | # get role to show Match details 8 | use Data::Dump::Tree::ExtraRoles ; 9 | 10 | # -------------------------------- 11 | # diff between two data structures 12 | # -------------------------------- 13 | 14 | my (%df1, %df2) := get_data_structures() ; 15 | 16 | # dumper with diff role 17 | my $d = Data::Dump::Tree.new does DDTR::Diff ; 18 | 19 | # show full structures with glyphs showing what differences exists 20 | $d.dump_synched: %df1, %df2, :compact_width, :does(DDTR::MatchDetails,) ; 21 | 22 | ''.say ; 23 | 24 | $d.dump_synched: %df1, %df2, :compact_width, :does(DDTR::MatchDetails,), :color_glyphs, 25 | 26 | # show only difference 27 | :!diff_glyphs, :remove_eq, :remove_eqv, 28 | 29 | # give names to the data structures 30 | :rhs_title<rhs_title>, 31 | :title<title> ; 32 | 33 | say "ran for {now - INIT now} s" ; 34 | 35 | 36 | 37 | # --------------- helpers -------------- 38 | 39 | sub get_data_structures 40 | { 41 | # define some elements to put in the data structures 42 | class O { has $.a ; } 43 | multi infix:<eqv>(O $l, O $r) { True } 44 | my $o1 = O.new(a => 1) ; 45 | my $o2 = O.new(a => 2) ; 46 | 47 | my $string1 = 'aaaaaaa' ; 48 | my $string2 = 'aaaaaaaa' ; 49 | my regex xxx { ($<t1> = [aaa] ) ($<t2> = a) } ; 50 | my regex yyy { ($<t1> = [aa] ) ($<t2> = a) a } ; 51 | my $match1 = $string1 ~~ m:g/<xxx>/ ; 52 | my $match2 = $string2 ~~ m:g/<yyy>/ ; 53 | 54 | my %xxx = %(< a 1 b 2 c 3 >), d => %( x => %( < y 1 >)), e => 1 ; 55 | 56 | # define the data structures 57 | my %df1 = M => $match1, A => %xxx, B => %(< a 1 b 2 c 3 >), C => %(< a 1 b 2 c 3 >), 58 | D => 3/10, E => 1, F => 2, G => %(< a 1 >), o => $o1 ; 59 | 60 | my %df2 = M => $match2, A => %xxx, B => %xxx, C => %(< a 1 b 2 c 3 >), 61 | D => 'hi', E => 2, F => %(< a 1 b 2 c 3 >), o => $o2 ; 62 | 63 | return %df1, %df2 ; 64 | } 65 | 66 | 67 | -------------------------------------------------------------------------------- /examples/diff_string.pl6: -------------------------------------------------------------------------------- 1 | 2 | use Data::Dump::Tree ; 3 | 4 | # get role to show diff 5 | use Data::Dump::Tree::Diff ; 6 | 7 | # get role to show Match details 8 | use Data::Dump::Tree::ExtraRoles ; 9 | 10 | # -------------------------------- 11 | # diff between two data strings 12 | # -------------------------------- 13 | 14 | my (@df1, @df2) := get_data_structures() ; 15 | 16 | # dumper with diff role 17 | my $d = Data::Dump::Tree.new does DDTR::Diff ; 18 | 19 | # show full structures with glyphs showing what differences exists 20 | $d.dump_synched: @df1, @df2, :compact_width, :does(DDTR::MatchDetails,), :color_glyphs ; 21 | 22 | ''.say ; 23 | 24 | # show only the differences between the structures 25 | $d.dump_synched: @df1, @df2, :compact_width, :does(DDTR::MatchDetails,), :color_glyphs, 26 | 27 | # show only difference 28 | :!diff_glyphs, :remove_eq, :remove_eqv, 29 | 30 | # give names to the data structures 31 | :title<title>, 32 | :rhs_title<rhs_title> ; 33 | 34 | say "ran for {now - INIT now} s" ; 35 | 36 | 37 | 38 | # --------------- helpers -------------- 39 | 40 | sub get_data_structures 41 | { 42 | my Str $s1 = "abccdefghijkln" ; 43 | my Str $s2 = "abcxdefghoijkn" ; 44 | 45 | return ($s1.comb(1), $s2.comb(1)) ; 46 | } 47 | 48 | 49 | -------------------------------------------------------------------------------- /examples/filter1.pl6: -------------------------------------------------------------------------------- 1 | 2 | use Data::Dump::Tree ; 3 | use Data::Dump::Tree::DescribeBaseObjects ; 4 | use Data::Dump::Tree::Enums ; 5 | 6 | use Terminal::ANSIColor ; 7 | 8 | # ------------------------------------------------------------------- 9 | # display a data structure after passing through user defined filters 10 | # ------------------------------------------------------------------- 11 | 12 | # the data structure to dump 13 | 14 | class Tomatoe{} 15 | class Potatoe{} 16 | 17 | my $s2 = 18 | [ 19 | 123, 20 | Tomatoe, 21 | Potatoe, 22 | { 23 | third => { a => 1}, 24 | }, 25 | ] ; 26 | 27 | ddt $s2, :title<unfiltered output>, :nl ; 28 | 29 | ddt $s2, :title<filtered output>, :nl, header_filters => (&my_filter,), elements_filters => (&my_filter,), footer_filters => (&my_filter,) ; 30 | ddt $s2, :title<filtered output>, header_filters => (&my_filter,) ; 31 | 32 | 33 | # ----------- 34 | # the filters 35 | # ----------- 36 | 37 | # everything is put in the same multi sub but different subs could have been used 38 | # filters match on their signatures too 39 | 40 | 41 | # HEADER FILTER 42 | multi sub my_filter($dumper, $r, Int $s, ($depth, $path, $glyph, @renderings), (\k, \b, \v, \f, \final, \want_address)) 43 | { 44 | # add text in the rendering 45 | @renderings.push: (|$glyph, (color('bold white on_yellow'), "Int HEADER filter", color('reset'))) ; 46 | 47 | # can replace ourselves with something else, do not forget to update k, b, v, accordingly 48 | # r = < abc def > ; 49 | 50 | k = '<my Int> ' ; 51 | b = '<my b>' ; 52 | v = '<my v>' ; 53 | f = '<my f>' ; 54 | final = DDT_NOT_FINAL ; 55 | want_address = True ; 56 | } 57 | 58 | 59 | # HEADER FILTER 60 | # called for every element in the data structure as $s, in the signature, is not typed 61 | multi sub my_filter($dumper, $r, $s, ($depth, $path, $glyph, @renderings), ($k, $b, $v, $f, $final, $want_address)) 62 | { 63 | # add text in the rendering 64 | @renderings.push: (|$glyph , ( '', "<" ~ $s.^name ~ '> @depth ' ~ $depth, '')) ; 65 | } 66 | 67 | 68 | # HEADER FILTER 69 | # replacement filter, matches Tomatoes, removes them from the dump 70 | multi sub my_filter($dumper, \r, Tomatoe $s, ($depth, $path, $glyph, @renderings), $) 71 | { 72 | # add text in the rendering 73 | @renderings.push: (|$glyph, (color('red'), 'removing tomatoe', color('reset'))) ; 74 | 75 | # remove tomatoe 76 | r = Data::Dump::Tree::Type::Nothing ; 77 | } 78 | 79 | 80 | # ELEMENTS FILTER 81 | # Match Hashes and replace their elements 82 | multi sub my_filter($dumper, Hash $s, ($, $glyph, @renderings, $), @sub_elements) 83 | { 84 | # add text in the rendering 85 | @renderings.push: (|$glyph, ('', "Changing elements of the Hash", '')) ; 86 | 87 | # new elements 88 | @sub_elements = (('new element 1', ': ', 2/3), ('new element 2', ': ', 2), ('new element 3', ': ', 3)) ; 89 | } 90 | 91 | 92 | 93 | # FOOTER FILTER 94 | # called for every element in the data structure as $s, in the signature, is not typed 95 | multi sub my_filter($dumper, $s, ($depth, $filter_glyph, @renderings)) 96 | { 97 | # add text in the rendering 98 | @renderings.push: (|$filter_glyph, ('', "</{$s.^name}>", '')) ; 99 | } 100 | 101 | 102 | -------------------------------------------------------------------------------- /examples/flat.pl6: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env perl6 2 | 3 | use Data::Dump::Tree ; 4 | use Data::Dump::Tree::MultiColumns ; 5 | 6 | #test1 ; 7 | test2 ; 8 | #test3 ; 9 | #test4 ; 10 | #test5 ; 11 | 12 | sub test1 13 | { 14 | ddt 1, 3, [[4..3], 1], :!color, :flat ; 15 | ddt 1, 3, [[4..3], 1], :!color ; 16 | ddt 1, 3, 4 ; 17 | ddt (1, 3, 4) ; 18 | ddt [1, 3, 4,], :flat ; 19 | } 20 | 21 | sub test2 22 | { 23 | ddt get_small_test_structure ; 24 | ddt get_small_test_structure, :flat ; 25 | 26 | ddt get_small_test_structure_hash ; 27 | ddt get_small_test_structure_hash, :flat ; 28 | } 29 | 30 | multi sub elements_filter( 31 | $dumper, 32 | Array $s, 33 | 34 | # rendering data you can optionaly use 35 | ($depth, $glyph, @renderings, ($key, $binder, $value, $path)), 36 | 37 | # elements you can modify 38 | @sub_elements 39 | ) 40 | { 41 | # optionaly add something in the rendering 42 | @renderings.push: (|$glyph, ('', 'SUB ELEMENTS', '')) ; 43 | 44 | # set/filter the elements 45 | @sub_elements.push: ('path', ' => ', $path.elems) ; 46 | } 47 | 48 | sub test3 49 | { 50 | #ddt get_test_structure ; 51 | #dd get_test_structure ; 52 | 53 | #ddt get_test_structure, :flat(0) ; 54 | ddt get_test_structure, :flat(0), :elements_filters(&elements_filter,) ; 55 | 56 | 57 | ddt get_test_structure, :flat(1) ; 58 | 59 | ddt get_test_structure, :flat(2) ; 60 | 61 | my $width = %+((qx[stty size] || '0 80') ~~ /\d+ \s+ (\d+)/)[0] ; 62 | $width = ($width / 2).Int ; 63 | 64 | display_columns 65 | get_dump_lines_integrated( 66 | get_test_structure, 67 | :$width, 68 | :flat(0), 69 | ), 70 | get_dump_lines_integrated( 71 | get_test_structure, 72 | :$width, 73 | :header_filters(), 74 | ) ; 75 | 76 | } 77 | 78 | sub test4 79 | { 80 | my @a = [4..5] ; 81 | my $d = [[[[1..2],[3..4],],]] ; 82 | my %h1 = <c 3> ; 83 | my %h2 = <a 1 b 2> ; 84 | my $s = ([1..3], %h1, %h2, @a) ; 85 | 86 | my %h3 = <a 1 b 2 c 3 d 4> ; 87 | my @a2 = [1..10] ; 88 | my $d2 = ([1..10], [|(1..10), @a2 ], %h3) ; 89 | 90 | my $d3 = ([1..10], [|(1..10), [|(1..22), %h1, %h2,%h2, |(23..30), [1..6], |(1..4)] ], {some => {a => 1, b => [|(1..5), %h1]}, thing => $s}) ; 91 | 92 | for 93 | ( 94 | (13, :title<test 10, string>, $s, :flat(10, <hello>)), 95 | (12, :title<test [1..3]>, $s, :flat([1..3],)), 96 | (14, :title<test Hash>, $s, :flat(Hash,)), 97 | (6, :title<test 0>, $s, :flat(0)), 98 | (11, :title<test 2>, ($d, [3..5]), :flat(2)), 99 | (14, :title<test 3>, ($d, [3..5], $d), :flat(3)), 100 | (13, :title<<test %(a => 1, b => 2)>>, $s, :flat(%(a => 1, b => 2),)), 101 | (14, :title<test %h1>, $s, :flat(%h1,)), 102 | (13, :title<test @a>, $s, :flat(@a,)), 103 | (14, :title<test sub: Hash>, $s, :flat({$_ ~~ Hash})), 104 | (12, :title<test sub Array $s.first: 3>, $s, :flat({$_ ~~ Array && $_.first: 3})), 105 | (14, :title<test sub: $s == %h1>, $s, :flat({$_ === %h1})), 106 | # columns 107 | (39, :title<flat()>, $d2, :flat()), 108 | (38, :title<flat((H, 2))>, $d2, :flat((Hash, 2),)), 109 | (22, :title<flat((sA, 2))>, $d2, :flat(({$_ ~~ Array && $*d == 1}, 2), )), 110 | (25, :title<flat((sA, L1, *5) 2)>, $d2, :flat(({$_ ~~ Array && $*d == 1, 5}, 2), )), 111 | (35, :title<flat((sA, L2, *5) 2)>, $d2, :flat(({$_ ~~ Array && $*d == 2, 5}, 2), )), 112 | (35, :title<flat((s@a2, L2, *5) 2)>, $d2, :flat(({$_ === @a2 && $*d == 2, 5}, 2), )), 113 | (35, :title<flat((sA, L2, *5) 2)>, $d2, :flat({$_ ~~ Array && $*d == 2, 5}, )), 114 | (21, :title<flat((sA, *5) 2)>, $d2, :flat(({$_ ~~ Array, 5}, 2), )), 115 | 116 | # hash flatten if more than two keys, if less only if keys are non final 117 | # array guess number of columns based on the number of elements and left space and rendering, which we know nothing about :) 118 | (53, :title<d3, flat(H, sA-5)>, $d3, :flat({$_ ~~ Hash && $_.keys > 1}, {$_ ~~ Array && $_.elems > 5, 5} )), 119 | ) 120 | { 121 | my ($lines, $title, $ds, $flat) = |$_ ; 122 | my Capture $c = \(|$title, $ds, |$flat) ; 123 | 124 | ddt |$c, :width(80) ; 125 | } 126 | } 127 | 128 | 129 | sub test5 130 | { 131 | my %h1 = <a 1 b 2> ; 132 | my %h2 = <d 3 e 4> ; 133 | 134 | ddt [1..3], %h1, %h2, 123, [1, [2, 3]], :display_perl_address ; 135 | ddt [1..3], %h1, %h2, 123, [1, [2, 3]], :flat, :display_perl_address ; 136 | ddt [1..3], %h1, %h2, 123, [1, [2, 3]], :flat(), :display_perl_address ; 137 | } 138 | 139 | # ------------- helpers ------------- 140 | 141 | sub get_test_structure 142 | { 143 | my $element = [1, [2, [3, 4]]] ; 144 | my $element2 = [1, 2] ; 145 | my $element3 = [ $element2, $element xx 11] ; 146 | 147 | my $data = [ $element, ([6, [3]],), $element ] ; 148 | 149 | my $s = ( 150 | $data, 151 | [ $element xx 2 ], 152 | $element3, 153 | [ |($element xx 2), $element2, [1...3], |($element xx 6) ], 154 | $element3, 155 | '12345678', 156 | ) ; 157 | 158 | $s ; 159 | } 160 | 161 | sub get_small_test_structure 162 | { 163 | my $element = [1, [2, [3, 4]]] ; 164 | my $element2 = [1, 2, Pair.new(3, [4, 5])] ; 165 | my $element3 = [ $element2, $element xx 11] ; 166 | 167 | my $data = [ $element, ([6, [3]],), $element ] ; 168 | 169 | my $s = ( 170 | [ $element xx 2 ], 171 | $element3, 172 | '12345678', 173 | $element3, 174 | ) ; 175 | 176 | $s ; 177 | } 178 | 179 | sub get_small_test_structure_hash 180 | { 181 | my $element = [1, [2, [3, 4]]] ; 182 | my $element2 = [1, 2, Pair.new(3, [4, 5])] ; 183 | my $element3 = [ $element2, $element xx 11] ; 184 | 185 | my $data = [ $element, ([6, [3]],), $element ] ; 186 | 187 | my %s = ( 188 | engine => [ $element xx 2 ], 189 | tires => $element3, 190 | ID => '12345678', 191 | components => $element3, 192 | ) ; 193 | 194 | %s ; 195 | } 196 | 197 | 198 | -------------------------------------------------------------------------------- /examples/folding.pl6: -------------------------------------------------------------------------------- 1 | 2 | use Data::Dump::Tree ; 3 | 4 | sub MAIN(Bool :$debug) 5 | { 6 | ddt :fold, get_s, :page_size(15), :$debug, :title<first> ; 7 | } 8 | 9 | # --------------------------------------------------------------------------------- 10 | 11 | sub get_s 12 | { 13 | my class Tomatoe{ has $.color ;} 14 | 15 | [ 16 | "111\n1212\ntest\nhello\ndone\n", 17 | {"222\n1212\ntest\nhello\ndone\n" => [1, [2.3]]}, 18 | Tomatoe, 19 | [ [ [ Tomatoe, ] ], ], 20 | 123, 21 | [ |(1..3) ], 22 | ] ; 23 | } 24 | 25 | -------------------------------------------------------------------------------- /examples/glyphs_color.pl6: -------------------------------------------------------------------------------- 1 | 2 | use Data::Dump::Tree ; 3 | use Data::Dump::Tree::DescribeBaseObjects ; 4 | use Data::Dump::Tree::ExtraRoles ; 5 | use Data::Dump::Tree::Enums ; 6 | 7 | my $m = [ [ |(1..3), [ |(1..3), [ |(1..3), [ |(1..3), [ 1..3 ] ] ], |(1..3) ] ], 1] ; 8 | 9 | my $d = Data::Dump::Tree.new ; 10 | $d does DDTR::SuperscribeType ; 11 | $d does DDTR::SuperscribeAddress ; 12 | 13 | $d.ddt: $m, :title<Glyphs> ; 14 | 15 | $d.ddt: $m, :title<Glyphs, numbered levels>, :does(DDTR::NumberedLevel,) ; 16 | 17 | $d.ddt: $m, :title<Glyphs, colored glyphs default>, :color_glyphs ; 18 | 19 | $d.ddt: $m, :title<Glyphs, custom colors, 3 first level green>, 20 | :colors(< gl_0 green gl_1 green gl_2 green >), 21 | :color_glyphs ; 22 | 23 | 24 | -------------------------------------------------------------------------------- /examples/gumbo.pl6: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env perl6 2 | 3 | use NativeCall ; 4 | 5 | use Data::Dump::Tree ; 6 | use Data::Dump::Tree::Enums ; 7 | use Data::Dump::Tree::DescribeBaseObjects ; 8 | 9 | class GumboSourcePosition is repr('CStruct') is export { 10 | has uint32 $.line; # unsigned int line 11 | has uint32 $.column; # unsigned int column 12 | has uint32 $.offset; # unsigned int offset 13 | } 14 | class GumboStringPiece is repr('CStruct') is export { 15 | has Str $.data; # const char* data 16 | has size_t $.length; # Typedef<size_t>->|unsigned int| length 17 | } 18 | class GumboVector is repr('CStruct') is export { 19 | has Pointer[Pointer] $.data; # void** data 20 | has uint32 $.length; # unsigned int length 21 | has uint32 $.capacity; # unsigned int capacity 22 | } 23 | class GumboAttribute is repr('CStruct') is export { 24 | has int32 $.attr_namespace; # GumboAttributeNamespaceEnum attr_namespace 25 | has Str $.name; # const char* name 26 | HAS GumboStringPiece $.original_name; # GumboStringPiece original_name 27 | has Str $.value; # const char* value 28 | HAS GumboStringPiece $.original_value; # GumboStringPiece original_value 29 | HAS GumboSourcePosition $.name_start; # GumboSourcePosition name_start 30 | HAS GumboSourcePosition $.name_end; # GumboSourcePosition name_end 31 | HAS GumboSourcePosition $.value_start; # GumboSourcePosition value_start 32 | HAS GumboSourcePosition $.value_end; # GumboSourcePosition value_end 33 | } 34 | class GumboDocument is repr('CStruct') is export { 35 | HAS GumboVector $.children; # GumboVector children 36 | has bool $.has_doctype; # bool has_doctype 37 | has Str $.name; # const char* name 38 | has Str $.public_identifier; # const char* public_identifier 39 | has Str $.system_identifier; # const char* system_identifier 40 | has int32 $.doc_type_quirks_mode; # GumboQuirksModeEnum doc_type_quirks_mode 41 | } 42 | class GumboText is repr('CStruct') is export { 43 | has Str $.text; # const char* text 44 | HAS GumboStringPiece $.original_text; # GumboStringPiece original_text 45 | HAS GumboSourcePosition $.start_pos; # GumboSourcePosition start_pos 46 | } 47 | class GumboElement is repr('CStruct') is export { 48 | HAS GumboVector $.children; # GumboVector children 49 | has int32 $.tag; # GumboTag tag 50 | has int32 $.tag_namespace; # GumboNamespaceEnum tag_namespace 51 | HAS GumboStringPiece $.original_tag; # GumboStringPiece original_tag 52 | HAS GumboStringPiece $.original_end_tag; # GumboStringPiece original_end_tag 53 | HAS GumboSourcePosition $.start_pos; # GumboSourcePosition start_pos 54 | HAS GumboSourcePosition $.end_pos; # GumboSourcePosition end_pos 55 | HAS GumboVector $.attributes; # GumboVector attributes 56 | } 57 | class GumboNode_v_Union is repr('CUnion') is export { 58 | HAS GumboDocument $.document; # GumboDocument document 59 | HAS GumboElement $.element; # GumboElement element 60 | HAS GumboText $.text; # GumboText text 61 | } 62 | class GumboNode is repr('CStruct') is export { 63 | has int32 $.type; # GumboNodeType type 64 | has GumboNode $.parent; # Typedef<GumboNode>->|GumboNode|* parent 65 | has size_t $.index_within_parent; # Typedef<size_t>->|unsigned int| index_within_parent 66 | has int32 $.parse_flags; # GumboParseFlags parse_flags 67 | HAS GumboNode_v_Union $.v; # Union v 68 | submethod TWEAK() { $!v := GumboNode_v_Union.new }; 69 | } 70 | class GumboOptions is repr('CStruct') is export { 71 | has Pointer $.allocator; # Typedef<GumboAllocatorFunction>->|F:void* ( void*, Typedef<size_t>->|unsigned int|)*| allocator 72 | has Pointer $.deallocator; # Typedef<GumboDeallocatorFunction>->|F:void ( void*, void*)*| deallocator 73 | has Pointer $.userdata; # void* userdata 74 | has int32 $.tab_stop; # int tab_stop 75 | has bool $.stop_on_first_error; # bool stop_on_first_error 76 | has int32 $.max_errors; # int max_errors 77 | has int32 $.fragment_context; # GumboTag fragment_context 78 | has int32 $.fragment_namespace; # GumboNamespaceEnum fragment_namespace 79 | } 80 | class GumboOutput is repr('CStruct') is export { 81 | has GumboNode $.document; # Typedef<GumboNode>->|GumboNode|* document 82 | has GumboNode $.root; # Typedef<GumboNode>->|GumboNode|* root 83 | HAS GumboVector $.errors; # GumboVector errors 84 | } 85 | 86 | 87 | dd GumboNode ; 88 | ''.say ; 89 | ddt GumboNode, :indent(' '), :nl ; 90 | 91 | #dd GumboNode.new ; 92 | #ddt GumboNode.new, :indent(' '), :nl ; 93 | 94 | my GumboNode $p = GumboNode.new ; 95 | my GumboNode $g = GumboNode.new ; 96 | #$g.parent := $p ; 97 | 98 | dd $g ; 99 | ''.say ; 100 | ddt $g, :indent(' '), :nl ; 101 | 102 | -------------------------------------------------------------------------------- /examples/highlight.pl6: -------------------------------------------------------------------------------- 1 | 2 | use Data::Dump::Tree ; 3 | use Data::Dump::Tree::Enums ; 4 | 5 | use Terminal::ANSIColor ; 6 | 7 | # ------------------------------------------------- 8 | # highlight some entries via a user defined filter 9 | # ------------------------------------------------- 10 | 11 | ddt [1..4], header_filters => (&my_filter,) ; 12 | 13 | 14 | # HEADER FILTER 15 | multi sub my_filter($dumper, \r, Int $s, ($depth, $path, $glyph, @renderings), (\k, \b, \v, \f, \final, \want_address)) 16 | { 17 | if $s == 1 { @renderings.push: (|$glyph, (color('bold white on_yellow'), ' add line in the graph', color('reset'))) } 18 | 19 | if $s == 2 { k = k ~ color('bold white on_yellow') ~ '*' } 20 | 21 | if $s == 3 { k = color('bold white on_yellow') ~ k } 22 | 23 | if $s == 4 { f = f ~ ' ' ~ color('bold white on_yellow') ~ 'an Int' } 24 | } 25 | 26 | -------------------------------------------------------------------------------- /examples/html.pl6: -------------------------------------------------------------------------------- 1 | 2 | use Data::Dump::Tree ; 3 | use Data::Dump::Tree::Enums ; 4 | use Data::Dump::Tree::ExtraRoles ; 5 | use Data::Dump::Tree::ColorBlobLevel ; 6 | 7 | use LWP::Simple; 8 | use DOM::Tiny ; 9 | 10 | my $t0 = now ; 11 | #my $html = DOM::Tiny.parse(LWP::Simple.get("http://www.google.com")); 12 | my $html = DOM::Tiny.parse('<div><p id="a" x="3">Test</p><p id="b">123</p></div>'); 13 | "parsing: {now - $t0} s".say ; 14 | 15 | $t0 = now ; 16 | #ddt $html ; 17 | "rendering: {now - $t0} s".say ; 18 | 19 | my $d = Data::Dump::Tree.new: 20 | :string_type(''), 21 | :string_quote('"'), 22 | :does[DDTR::ColorBlobLevel], 23 | :color_kbs, 24 | :header_filters[&header], 25 | :elements_filters[&final_first, &elements], 26 | :nl ; 27 | 28 | $t0 = now ; 29 | $d.ddt: $html ; 30 | "rendering: {now - $t0} s".say ; 31 | 32 | multi sub header($, \r, DOM::Tiny::HTML::Tag $s, @, (\k, \b, \v, \f, \final, \want_address)) 33 | { 34 | #Make tag nodes look like html a bit 35 | 36 | k = '<' ~ $s.tag ~ ' ' ~ $s.attr.kv.map(-> $k, $v {"$k=$v"}).join(' ') ~ '>' ; 37 | b = ' ' ; 38 | 39 | if $s.children.elems == 1 && $s.children[0] ~~ DOM::Tiny::HTML::Text 40 | { 41 | v = $s.children[0].text ; 42 | final = True ; 43 | } 44 | else 45 | { 46 | v = Data::Dump::Tree::Type::Nothing ; 47 | } 48 | 49 | f = '' ; 50 | want_address = False ; 51 | } 52 | 53 | multi sub elements($, $s, @, @sub_elements) 54 | { 55 | # remove DOM::Tiny attributes we do not want to see 56 | @sub_elements = @sub_elements.grep: 57 | { 58 | $_[0] !~~ 59 | '%.attr is rw' | 60 | '$.parent is rw' | 61 | '$.tag is rw' | 62 | '$.rcdata is rw' 63 | } ; 64 | 65 | # if it's a tag element display @children directly under element 66 | if $s ~~ DOM::Tiny::HTML::Tag 67 | { 68 | my @new_elements ; 69 | 70 | for @sub_elements.grep({ $_[0] ~~ '@.children is rw' }) -> $e 71 | { 72 | my ($k, $b, $v, $p) = $e ; 73 | for $v.List 74 | { 75 | @new_elements.push: $_ ~~ DOM::Tiny::HTML::Text | DOM::Tiny::HTML::Raw 76 | ?? ('', '', $_.text) 77 | !! ('', '', $_) ; 78 | } 79 | } 80 | 81 | @sub_elements = @new_elements ; 82 | } 83 | } 84 | 85 | multi sub final_first($dumper, $, $, @sub_elements) 86 | { 87 | @sub_elements = @sub_elements.sort: { $dumper.get_element_header($^a[2])[2] !~~ DDT_FINAL } 88 | } 89 | 90 | -------------------------------------------------------------------------------- /examples/int32.pl6: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env perl6 2 | 3 | use NativeCall ; 4 | 5 | use Data::Dump::Tree ; 6 | use Data::Dump::Tree::Enums ; 7 | use Data::Dump::Tree::DescribeBaseObjects ; 8 | 9 | role my_role { has $.something } # test that Int+something type displays correctly 10 | 11 | class Point is repr('CStruct') { 12 | has num64 $.x is rw; 13 | has num32 $.y; 14 | has int32 $.z = 3; 15 | } 16 | 17 | my $point = Point.new: :x(2e56), :y(10e10) ; 18 | 19 | class Parts is repr('CUnion') { 20 | has int32 $.xyz; 21 | has int64 $.abc; 22 | } 23 | 24 | my Parts $union = Parts.new: :abc(10 ** 10) ; 25 | 26 | class MyStruct is repr('CStruct') { 27 | has Point $.point; # referenced 28 | submethod TWEAK() { $!point := Point.new }; 29 | } 30 | 31 | my $mystruct = MyStruct.new ; 32 | $mystruct.point.x = (my num64 $ = 888e0) ; 33 | 34 | class MyStruct2 is repr('CStruct') { 35 | HAS Point $.point; # embedded 36 | submethod TWEAK() { $!point := Point.new }; 37 | } 38 | 39 | my $mystruct2 = MyStruct2.new ; 40 | $mystruct2.point.x = (my num64 $ = 777e0) ; 41 | 42 | 43 | 44 | class MyStruct3 is repr('CStruct') { 45 | HAS Point $.point; # embedded 46 | has int32 $.int32 ; 47 | submethod TWEAK() { $!point := Point.new }; 48 | } 49 | 50 | my $mystruct3 = MyStruct3.new: :int32(7) ; 51 | $mystruct.point.x = (my num64 $ = 777e0) ; 52 | 53 | 54 | sub add_p6(Int, Int) returns Int { 1 } 55 | sub some_argless_function() is native('something') { * } 56 | our sub init() is native('foo') is symbol('FOO_INIT') { * } 57 | sub add(int32, int32) returns int32 is native("calculator") { * } 58 | sub Foo_init() returns Pointer is native("foo") { * } 59 | 60 | class Types is repr('CStruct') { 61 | has int8 $.a1 ; 62 | has int16 $.a2 ; 63 | has int32 $.a3 ; 64 | has int64 $.a4 ; 65 | has uint8 $.a5 ; 66 | has uint16 $.a6 ; 67 | has uint32 $.a7 ; 68 | has uint64 $.a8 ; 69 | has long $.a9 ; 70 | has longlong $.a10 ; 71 | has ulong $.a11 ; 72 | has ulonglong $.a12 ; 73 | has num32 $.a13 ; 74 | has num64 $.a14 ; 75 | has Str $.a15 ; 76 | has CArray[int32] $.a16 ; 77 | has Pointer[void] $.a17 ; 78 | has bool $.a18 ; 79 | has size_t $.a19 ; 80 | has ssize_t $.a20 ; 81 | } 82 | 83 | my $types = Types.new ; 84 | 85 | class MyHandle is repr('CPointer') {} 86 | my Pointer[int32] $pointer ; 87 | 88 | my int32 $int32 = 7 ; 89 | my @with_int32 = $int32, 7, 8 ; 90 | my int32 @int32 = $int32, 7, 8 ; 91 | 92 | my $string = "FOO"; 93 | my @carray := CArray[uint8].new($string.encode.list); 94 | 95 | my $carray_titles = CArray[Str].new; 96 | $carray_titles[0] = 'Me'; 97 | $carray_titles[1] = 'You'; 98 | 99 | class StructiWithHandler is repr('CStruct') { has int32 $.flags } 100 | 101 | role DDT_SWH 102 | { 103 | multi method get_header (StructiWithHandler $s) 104 | { 'In DDT Handler', '.' ~ $s.^name, DDT_FINAL } 105 | } 106 | 107 | my $d1 = (&add_p6, &add, &init, &some_argless_function, &Foo_init) ; 108 | my $d2 = (MyHandle, $pointer) ; 109 | my $d3 = ($int32, @with_int32, @int32, @carray, $carray_titles, ) ; 110 | my $d4 = (Types, $types) ; 111 | my $d5 = (Point, $point, $union, MyStruct) ; 112 | my $d6 = StructiWithHandler ; 113 | 114 | my $d7 = (MyStruct, MyStruct.new, $mystruct, DVO "native_size: {nativesizeof MyStruct}", ) ; 115 | my $d8 = (MyStruct2, MyStruct2.new, $mystruct2, DVO "native_size: {nativesizeof MyStruct2}", ) ; 116 | my $d9 = (MyStruct3, MyStruct3.new, $mystruct3, DVO "native_size: {nativesizeof MyStruct3}", ) ; 117 | 118 | ddt $d1, :indent(' '), :nl ; 119 | ddt $d2, :indent(' '), :nl ; 120 | ddt $d3, :indent(' '), :nl ; 121 | ddt $d4, :indent(' '), :flat(0), :nl ; 122 | 123 | ddt $d5, :indent(' '), :nl ; 124 | ddt $d6, :does[DDT_SWH], :indent(' '), :nl ; 125 | 126 | ddt $d7, :indent(' '), :nl ; 127 | ddt $d8, :indent(' '), :nl ; 128 | ddt $d9, :indent(' '), :nl ; 129 | 130 | # IRL example 131 | 132 | class wrong_rgba_color_s is repr('CStruct'){ 133 | has int32 $.red; 134 | has int32 $.blue; 135 | has int32 $.green; 136 | } 137 | 138 | class rgba_color_s is repr('CStruct'){ 139 | has int32 $.red; 140 | has int32 $.blue; 141 | has int32 $.green; 142 | has int32 $.alpha; 143 | } 144 | 145 | 146 | #struct s_toyunda_sub { 147 | # usigned int start; 148 | # usigned int stop; 149 | # char* text; 150 | # rgba_color_t color1; 151 | # rgba_color_t color2; 152 | # rgba_color_t tmpcolor; 153 | # float positionx; 154 | # float positiony; 155 | # float position2x; 156 | # float position2y; 157 | # float fadingpositionx; 158 | # float fadingpositiony; 159 | # int size; 160 | # int size2; 161 | # int fadingsize; 162 | # char* image; 163 | #}; 164 | 165 | class toyunda_subtitle_s is repr('CStruct') { 166 | has int32 $.start; 167 | has int32 $.stop; 168 | 169 | has Str $.text; 170 | HAS rgba_color_s $.color1; 171 | HAS rgba_color_s $.color2; 172 | has rgba_color_s $.tmpcolor; # it should be HAS 173 | 174 | has num32 $.positionx; 175 | has num32 $.positiony; 176 | has num32 $.position2x; 177 | has num32 $.position2y; 178 | has num32 $.fadingpositionx; 179 | has num32 $.fadingpositiony; 180 | 181 | has int32 $.size; 182 | has int32 $.size2; 183 | has int32 $.fadingsize; 184 | 185 | has str $.image; # bad use of str 186 | } 187 | 188 | ddt toyunda_subtitle_s, :indent(' '), :nl ; 189 | ddt toyunda_subtitle_s.new, :indent(' '), :nl ; 190 | 191 | 192 | -------------------------------------------------------------------------------- /examples/jddt.pl6: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env perl6 2 | 3 | use Data::Dump::Tree ; 4 | use Data::Dump::Tree::Enums ; 5 | use Data::Dump::Tree::ExtraRoles ; 6 | use JSON::Tiny ; 7 | 8 | sub MAIN($file_name, Bool :$keep_lines = False) 9 | { 10 | my $json = from-json($file_name.IO.slurp) ; 11 | 12 | my $d = Data::Dump::Tree.new does DDTR::FixedGlyphs(' ') ; 13 | 14 | 15 | $d.ddt: $json, 16 | :title("$file_name:"), 17 | :nl, 18 | :!display_type, 19 | :display_address(DDT_DISPLAY_NONE), 20 | :color_kbs, 21 | :elements_filters[&json_filter] ; 22 | #:elements_filters[&final_first, &non_final_no_binder, &align_keys] ; 23 | } 24 | 25 | sub final_first($dumper, $, $, @sub_elements) 26 | { 27 | @sub_elements = @sub_elements.sort: { $dumper.get_element_header($^a[2])[2] !~~ DDT_FINAL } 28 | } 29 | 30 | sub non_final_no_binder ($dumper, $, $, @sub_elements) 31 | { 32 | for @sub_elements -> ($k, $binder is rw, $value, $) 33 | { 34 | $binder = '' if $dumper.get_element_header($value)[2] !~~ DDT_FINAL ; 35 | } 36 | } 37 | 38 | sub align_keys ($dumper, $, $, @sub_elements) 39 | { 40 | my $max_kb = ( my @cache = @sub_elements.map: { (.[0] ~ .[1]).chars }).max ; 41 | 42 | for @sub_elements Z @cache -> (@e, $l) { @e[0] ~= ' ' x $max_kb - $l } 43 | } 44 | 45 | sub json_filter($dumper, $, $, @sub_elements) 46 | { 47 | my (@finals, @non_finals) ; 48 | 49 | my $max_kb = ( my @cache = @sub_elements.map: { (.[0] ~ .[1]).chars }).max ; 50 | 51 | for (@sub_elements Z @cache) -> (@e, $l) 52 | { 53 | my $padded = @e[0] ~ ' ' x $max_kb - $l ; 54 | 55 | if $dumper.get_element_header(@e[2])[2] ~~ DDT_FINAL 56 | { 57 | @finals.push: ($padded, |@e[1..*]) ; 58 | } 59 | else 60 | { 61 | @non_finals.push: ($padded, '', |@e[2..*]) ; 62 | } 63 | } 64 | 65 | @sub_elements = |@finals, |@non_finals ; 66 | } 67 | 68 | -------------------------------------------------------------------------------- /examples/jflat.pl6: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env perl6 2 | 3 | use Data::Dump::Tree ; 4 | use Data::Dump::Tree::Enums ; 5 | use Data::Dump::Tree::ExtraRoles ; 6 | 7 | use JSON::Tiny ; 8 | 9 | sub MAIN($file_name, Bool :$keep_lines = False) 10 | { 11 | my $json = from-json($file_name.IO.slurp) ; 12 | 13 | my $d = Data::Dump::Tree.new ; 14 | 15 | require ($*PROGRAM.parent(1).absolute ~ "/CustomSetup/DataSource.pm6") <DataSource> ; 16 | my regex { 1 } 17 | 18 | $d.ddt: $json, 19 | :title("$file_name:"), 20 | :!display_type, 21 | :color_kbs, 22 | :elements_filters[&final_first] ; 23 | 24 | $d.ddt: $json, 25 | :title("$file_name:"), 26 | :!display_type, 27 | :color_kbs, 28 | :does[DataSource], 29 | :elements_filters[&final_first] ; 30 | } 31 | 32 | sub final_first($dumper, $, $, @sub_elements) 33 | { 34 | @sub_elements = @sub_elements.sort: { $dumper.get_element_header($^a[2])[2] !~~ DDT_FINAL } 35 | } 36 | 37 | -------------------------------------------------------------------------------- /examples/junctions.pl6: -------------------------------------------------------------------------------- 1 | 2 | #!/usr/bin/env perl6 3 | 4 | use Data::Dump::Tree ; 5 | my $d = Data::Dump::Tree.new ; 6 | 7 | my $j = 1 | 'a' & True ; 8 | class C { has $.j } ; 9 | 10 | $d.ddt: C.new(:$j) ; 11 | 12 | $d.ddt: $j ; 13 | 14 | $d.ddt: [ ($j) ] ; 15 | 16 | -------------------------------------------------------------------------------- /examples/long_folding.pl6: -------------------------------------------------------------------------------- 1 | 2 | use Data::Dump::Tree ; 3 | 4 | sub MAIN(Bool :$debug) 5 | { 6 | ddt :fold, get_s(400), :$debug, :title<first> ; 7 | } 8 | 9 | # --------------------------------------------------------------------------------- 10 | 11 | sub get_s($n = 100) 12 | { 13 | 14 | my @p = item {}; 15 | for ^$n 16 | { 17 | my $ds = (Hash, Array).pick.new; 18 | my $to = @p[(^@p).pick]; 19 | $to ~~ Hash 20 | ?? ($to{join '', ('a'..'z').pick xx 5} = $ds) 21 | !! $to.push($ds); @p.push($ds) 22 | } 23 | 24 | @p[0] 25 | } 26 | 27 | -------------------------------------------------------------------------------- /examples/match.pl6: -------------------------------------------------------------------------------- 1 | 2 | use Data::Dump::Tree ; 3 | use Data::Dump::Tree::ExtraRoles ; 4 | use Data::Dump::Tree::Enums ; 5 | 6 | # content to be matched 7 | my $contents = q:to/EOI/; 8 | [passwords] 9 | jack=password1 10 | joy=muchmoresecure123 11 | [quotas] 12 | jack=123 13 | joy=42 14 | EOI 15 | 16 | # define some regexp structure 17 | my regex header { \s* ('[' \w+ ']') \h* \n+ } 18 | my regex identifier { \w+ } 19 | my regex kvpair { \s* <key=identifier> '=' <value=identifier> \n+ } 20 | my regex section { <header> <kvpair>* } 21 | 22 | # create a match object to dump 23 | my $m = $contents ~~ /<section>*/ ; 24 | 25 | # dump with different roles 26 | my $d = Data::Dump::Tree.new :title<Match> ; 27 | 28 | $d.ddt: $m ; 29 | 30 | $d does DDTR::MatchDetails ; 31 | $d does DDTR::SuperscribeType ; 32 | $d does DDTR::SuperscribeAddress ; 33 | 34 | $d.ddt: :title('Match (MatchDetails)'), $m ; 35 | 36 | $d does DDTR::PerlString ; 37 | $d.ddt: :title<Match (MatchDetails, PerlString)>, $m ; 38 | 39 | $d.match_string_limit = 40 ; 40 | $d.ddt: :title<Match (MatchDetails, PerlString+max length)>, $m ; 41 | 42 | $d.ddt: :title<Match (MatchDetails, PerlString+ml, FixedGlyphs, custom colors, no address)>, 43 | $m, 44 | :does(DDTR::FixedGlyphs,), 45 | :display_address(DDT_DISPLAY_NONE), 46 | :colors(< 47 | ddt_address 17 perl_address 58 link 23 48 | key 32 binder 32 value 246 header 53 49 | wrap 23 50 | >) ; 51 | 52 | $d.ddt: :title<Match (MatchDetails, PerlString+ml, FixedGlyphs, custom colors2, no address)>, 53 | $m , 54 | :does(DDTR::FixedGlyphs,), 55 | :display_address(DDT_DISPLAY_NONE), 56 | :color_kbs ; 57 | 58 | sub header_filter($dumper, \r, $s, ($depth, $path, $glyph, @renderings), (\k, \b, \v, \f, \final, \want_address)) 59 | { 60 | # add text in the rendering 61 | #@renderings.push: (|$glyph, ('***', "HEADER filter", '***')) ; 62 | 63 | # <header> replaced by its match 64 | if k eq "<header>" 65 | { 66 | my %caps = $s.caps ; 67 | 68 | v = "%caps<0>" ; 69 | f = %caps<0>.from ~ '..' ~ (%caps<0>.pos - 1) ; 70 | final = DDT_FINAL ; 71 | } 72 | 73 | # <section> have not text but a range 74 | if k eq "<section>" { v = '' ; } 75 | 76 | # <kvpair> has neither text nor range 77 | if k eq "<kvpair>" { v = '' ; f = '' ; } 78 | } 79 | 80 | sub elements_filter($dumper, $s, ($depth, $glyph, @renderings, $element), @sub_elements) 81 | { 82 | my ($k, $b) = $element ; 83 | 84 | @sub_elements = @sub_elements.grep({$_[0] ne '<identifier>' }) if $k eq "<kvpair>" ; 85 | } 86 | 87 | sub ls(Str $s, $limit) 88 | { 89 | $limit.defined && $s.chars > $limit 90 | ?? $s.substr(0, $limit) ~ '(+' ~ $s.chars - $limit ~ ')' 91 | !! $s 92 | } 93 | 94 | #$d.ddt: :title<Match (MatchDetails, PerlString+ml, FixedGlyphs, custom colors2, no address)>, 95 | $d.ddt: $m , 96 | :does(DDTR::FixedGlyphs,), 97 | :display_address(DDT_DISPLAY_NONE), 98 | :header_filters(&header_filter,), 99 | :elements_filters(&elements_filter,), 100 | :color_kbs ; 101 | 102 | 103 | -------------------------------------------------------------------------------- /examples/named_captures.pl6: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env perl6 2 | 3 | use Data::Dump::Tree ; 4 | use Data::Dump::Tree::Enums ; 5 | use Data::Dump::Tree::ExtraRoles ; 6 | use Data::Dump::Tree::DescribeBaseObjects ; 7 | 8 | # ---------------------------------------------------- 9 | # display result of regex matching with named captures 10 | # ---------------------------------------------------- 11 | 12 | # displaying the addresses adds no value to the dump, disable it 13 | my $d = Data::Dump::Tree.new(:display_address(DDT_DISPLAY_NONE)) does DDTR::MatchDetails(40) ; 14 | 15 | $d.ddt: 'aaaaabx' ~~ m:g/ ($<token> = a) ($<T2> = a) ./, :title('"aaaaabx" ~~ m:g/ ($<token> = a) ($<T2> = a) ./>') ; 16 | 17 | $d.ddt: 'abc-abc-abc' ~~ / $<string>=( [ $<part>=[abc] ]* % '-' ) /, :title('"abc-abc-abc" ~~ / $<string>=( [ $<part>=[abc] ]* % "-" ) />') ; 18 | 19 | 20 | # larger example 21 | my regex header { \s* '[' (\w+) ']' \h* \n+ } 22 | my regex identifier { \w+ } 23 | my regex kvpair { \s* <key=identifier> '=' <value=identifier> \n+ } 24 | my regex section { 25 | <header> 26 | <kvpair>* 27 | } 28 | 29 | my $config = q:to/EOI/; 30 | [passwords] 31 | jack=password1 32 | joy=muchmoresecure123 33 | [quotas] 34 | jack=123 35 | joy=42 36 | EOI 37 | 38 | my $regex = regex { \s* '[' (\w+) ']' \h* \n+ } 39 | 40 | my $match = $config ~~ /<section>*/ ; 41 | 42 | my $dump_start = now ; 43 | 44 | $d.dump({ :$config, :$regex, :$match }, title => 'config parsing', elements_filters => (&sorter,)) ; 45 | 46 | # filter display the elements in a specific order 47 | # for the only hash that will be in the dump 48 | # for names <config regex match> 49 | # get the element in hash where the key is the name 50 | # 51 | multi sub sorter($dumper, Hash $s, $, @sub_elements) 52 | { 53 | my %h = @sub_elements.map: -> $e { $e[0] => $e } ; 54 | @sub_elements = <config regex match>.map: -> $e { %h{$e} } 55 | } 56 | 57 | say "dump time: {now - $dump_start} s" ; 58 | say "total time {now - INIT now} s" ; 59 | 60 | -------------------------------------------------------------------------------- /examples/named_elements.pl6: -------------------------------------------------------------------------------- 1 | use Data::Dump::Tree ; 2 | use Data::Dump::Tree::Enums ; 3 | use Terminal::ANSIColor ; 4 | 5 | my @a = 1 ; 6 | my $b = [< a >] ; 7 | my $list = (<a>, $b) ; 8 | 9 | my $s = [ 10 | 'text', 11 | @a, 12 | $b, 13 | @a, 14 | $b, 15 | $list, 16 | ] ; 17 | 18 | my $d = Data::Dump::Tree.new ; 19 | 20 | # add a name to some containers to make it easier to see them in the dump 21 | # the name is displayed after the address (and the link to an address) so 22 | # addresses must be enabled. Enabling address display is recommended when 23 | # dumping a structure with linked data 24 | 25 | $d.set_element_name: $s[2], 'list b' ; 26 | 27 | # color the name 28 | $d.set_element_name: @a, color('bold yellow on_red') ~ 'some array' ; 29 | 30 | $d.ddt: $s ; 31 | 32 | say "ran for {now - INIT now} s" ; 33 | 34 | -------------------------------------------------------------------------------- /examples/paths.pl6: -------------------------------------------------------------------------------- 1 | use Data::Dump::Tree ; 2 | 3 | class Tomatoe{ has $.color ;} 4 | class Potatoe{} 5 | 6 | my $s = 7 | [ 8 | Tomatoe, 9 | [ [ Tomatoe,], ], 10 | 123, 11 | Tomatoe.new( color => 'green'), 12 | ] ; 13 | 14 | 15 | my $d = Data::Dump::Tree.new ; 16 | $d.ddt: $s, :keep_paths, :header_filters(&header_filter,) ; 17 | 18 | say "ran for {now - INIT now} s" ; 19 | 20 | multi sub header_filter($dumper, \r, $s, ($depth, $path, $glyph, @renderings), $) 21 | { 22 | # $path contains a list of [parent, key (as rendered)] 23 | 24 | # the rendering of the path information is simplistic, take the parent object 25 | # get a rendering from the dumper, IE an array of 6 elements would give [6] 26 | # append it to the key, and add it as an extra information to the current 27 | # element. Eg: element 3 of an array of 6 elements would be rendered 28 | # as [6]/3. 29 | 30 | my $path_rendered = ('', ($path.map: { $d.get_element_header($_[0])[1] ~ '/' ~ $_[1]}).join(' '), '').List ; 31 | 32 | @renderings.push: (|$glyph, ('', 'path:', ''), $path_rendered) ; 33 | } 34 | 35 | -------------------------------------------------------------------------------- /examples/perltricks_examples.pl6: -------------------------------------------------------------------------------- 1 | use Data::Dump::Tree ; 2 | use Data::Dump::Tree::DescribeBaseObjects ; 3 | use Terminal::ANSIColor ; 4 | 5 | ''.say ; 6 | ddt [1..100], :nl, :indent(' ') ; 7 | 8 | dd [1..100] ; 9 | ''.say ; 10 | ddt [1..100], :flat({1, 5, 10}), :indent(' '), :nl ; 11 | 12 | dd True, [(1..100).pick: 100], :nl , :indent(' '), :nl ; 13 | ''.say ; 14 | ddt True, [(1..100).pick: 100], :flat({1, 10, 10}), :nl, :indent(' ') ; 15 | 16 | dd True, [(1..300).pick: 300], :nl , :indent(' '), :nl ; 17 | ''.say ; 18 | ddt True, [(1..300).pick: 300], :flat({1, 10, 12}), :nl, :indent(' ') ; 19 | 20 | 21 | role skinny 22 | { 23 | multi method get_elements (Array $a) 24 | { 25 | $a.list.map: 26 | { 27 | '', 28 | '', 29 | 50 <= $_ < 60 30 | ?? DVO(color('bold red') ~ $_.fmt("%4d") ~ color('reset')) 31 | !! DVO($_.fmt("%4d")) 32 | } 33 | } 34 | 35 | } 36 | 37 | 38 | 39 | ddt True, [(1..100).pick: 100], :flat({1, 10}), :does[skinny], :indent(' ') ; 40 | 41 | 42 | -------------------------------------------------------------------------------- /examples/remote/fold_receive.pl6: -------------------------------------------------------------------------------- 1 | use v6.c; 2 | 3 | use Data::Dump::Tree ; 4 | use Data::Dump::Tree::Foldable ; 5 | use Data::Dump::Tree::TerminalFoldable ; 6 | 7 | use MONKEY-SEE-NO-EVAL; 8 | use experimental :pack ; 9 | 10 | # https://github.com/FROGGS/p6-Ser/blob/master/lib/Ser.pm 11 | 12 | sub MAIN(:$port = 4444, Bool :$timestamp, Bool :$counter, Bool :$help) 13 | { 14 | 15 | with $help { display_help() and exit 0 } 16 | 17 | "listening on: localhost port: $port".say ; 18 | 19 | my $listen = IO::Socket::INET.new(:listen, :localhost<localhost>, :localport($port)); 20 | 21 | loop 22 | { 23 | my $connection = $listen.accept ; 24 | 25 | my $t0 = now ; 26 | 27 | my $elements = $connection.read(4).unpack('N') // 0 ; 28 | 29 | "$port:{DateTime.now}".say if $timestamp ; 30 | "receiving foldable, elements: $elements".say if $counter ; 31 | 32 | my @lines = my_receive(:$connection, :size($connection.read(4).unpack('N') // 0), :$counter) xx $elements ; 33 | my @line_lengths = ($connection.read(4).unpack('N') // 0) xx $elements ; 34 | my @folds = [ ($connection.read(4).unpack('N') // 0) xx 4 ] xx $elements ; 35 | 36 | $connection.close ; 37 | "reception time: {now - $t0}".say if $timestamp ; 38 | 39 | my $foldable = Data::Dump::Tree::Foldable.new: :@lines, :@line_lengths, :@folds ; 40 | display_foldable($foldable) ; 41 | } 42 | 43 | } 44 | 45 | sub my_receive(:$connection, :$size, :$counter = 0) 46 | { 47 | my $received = 0 ; 48 | my $line = '' ; 49 | 50 | while $received < $size 51 | { 52 | my $buffer = $connection.read($size) ; 53 | $line ~= $buffer.decode('utf8') ; 54 | 55 | $received += $buffer.bytes ; 56 | "received: {$buffer.bytes}, total: $received".say if $counter ; 57 | } 58 | 59 | $line 60 | } 61 | 62 | sub display_help 63 | { 64 | my $help = qq:to/EOH/ ; 65 | Keyboard Mapping: 66 | ================= 67 | 68 | q quit 69 | 70 | Selection: 71 | ---------- 72 | e selection line up 73 | d selection line down 74 | 75 | Folding: 76 | -------- 77 | r reset 78 | a fold all 79 | u unfold all 80 | CursorLeft or CursorRight flip folding 81 | 82 | Navigation: 83 | ----------- 84 | CursorUp 85 | CursorDown 86 | PageUp 87 | PageDown 88 | Home 89 | End 90 | 91 | 92 | EOH 93 | 94 | $help.say ; 95 | 96 | } 97 | 98 | 99 | -------------------------------------------------------------------------------- /examples/remote/fold_send.pl6: -------------------------------------------------------------------------------- 1 | use Data::Dump::Tree ; 2 | use Data::Dump::Tree::Ddt ; 3 | 4 | sub MAIN 5 | { 6 | my $s = [1, [1, [1..2]]] ; 7 | 8 | my $size = ddt :remote_fold, get_s(), :title<remote_fold> ; 9 | 10 | "Send $size bytes of fold data to remote.".say if $size ; 11 | } 12 | 13 | # ----------------------------------------------------------------------------------------- 14 | 15 | sub get_s($n = 100) 16 | { 17 | 18 | my @p = item {}; 19 | for ^$n 20 | { 21 | my $ds = (Hash, Array).pick.new; 22 | my $to = @p[(^@p).pick]; 23 | $to ~~ Hash 24 | ?? ($to{join '', ('a'..'z').pick xx 5} = $ds) 25 | !! $to.push($ds); @p.push($ds) 26 | } 27 | 28 | @p[0] 29 | } 30 | 31 | -------------------------------------------------------------------------------- /examples/remote/lfl.pl6: -------------------------------------------------------------------------------- 1 | 2 | use Data::Dump::Tree ; 3 | 4 | sub MAIN(Bool :$debug) 5 | { 6 | ddt :fold, get_s(400), :max_lines(25), :$debug, :title<first> ; 7 | } 8 | 9 | # --------------------------------------------------------------------------------- 10 | 11 | sub get_s($n = 100) 12 | { 13 | 14 | my @p = item {}; 15 | for ^$n 16 | { 17 | my $ds = (Hash, Array).pick.new; 18 | my $to = @p[(^@p).pick]; 19 | $to ~~ Hash 20 | ?? ($to{join '', ('a'..'z').pick xx 5} = $ds) 21 | !! $to.push($ds); @p.push($ds) 22 | } 23 | 24 | @p[0] 25 | } 26 | 27 | -------------------------------------------------------------------------------- /examples/remote/receive.pl6: -------------------------------------------------------------------------------- 1 | use v6.c; 2 | 3 | use experimental :pack; 4 | 5 | # This example is teken directly from the Perl6 documention. 6 | # It's a no thrill print server on localhost, it will say what you send it. 7 | 8 | sub MAIN(:$port = 3333, Bool :$timestamp, Bool :$counter) 9 | { 10 | "listening on: localhost port: $port".say ; 11 | 12 | my $listen = IO::Socket::INET.new(:listen, :localhost<localhost>, :localport($port)); 13 | loop 14 | { 15 | my $connection = $listen.accept ; 16 | 17 | my $buffer = $connection.read(4) ; 18 | "$port:{DateTime.now}".say if $timestamp ; 19 | 20 | my $size = $buffer.unpack('N') ; 21 | "receiving: $size".say if $counter ; 22 | 23 | my $received = 0 ; 24 | my $block = '' ; 25 | 26 | while $block.chars < $size 27 | { 28 | $buffer = $connection.recv(:bin) ; 29 | $block ~= $buffer.decode('utf8') ; 30 | 31 | $received += $buffer.elems ; 32 | "received: {$buffer.elems}, total: $received".say if $counter ; 33 | } 34 | 35 | "decoded: {$block.chars} characters".say if $counter; 36 | $block.say ; 37 | 38 | $connection.close; 39 | } 40 | } 41 | -------------------------------------------------------------------------------- /examples/remote/send_big.pl6: -------------------------------------------------------------------------------- 1 | 2 | use Data::Dump::Tree ; 3 | use Data::Dump::Tree::Ddt ; # for ddt_remote 4 | 5 | # a data structure we know will be more than 64 KB in size when we send it 6 | # over the network 7 | my $s = [|(1..1_500)]; 8 | 9 | "object.perl.chars: {$s.perl.chars}".say ; 10 | 11 | # send a textual representation 12 | ddt :title<:remote>, $s, :remote ; 13 | 14 | # send a foldable object, IE a rendering of the object, slow to EVAL but already rendered 15 | ddt :title<:remote_fold>, $s, :remote_fold ; 16 | 17 | 18 | 19 | -------------------------------------------------------------------------------- /examples/removal.pl6: -------------------------------------------------------------------------------- 1 | 2 | use Data::Dump::Tree ; 3 | 4 | my $s = 5 | [ 6 | 123, 7 | 456, 8 | class Tomatoe {has $.seeds}.new(:seeds<3>), 9 | ] ; 10 | 11 | " 12 | NOTE: the array shows 3 elements even when an element is removed, this is because 13 | the filters is done after the header for the Array is rendered 14 | ". say ; 15 | 16 | ddt $s, :title<With Tomatoe>, :nl ; 17 | ddt $s, :title<remove Tomatoe>, :nl, removal_filters => (&remove_tomatoe,) ; 18 | ddt $s, :title<Filter Nil>, :nl, removal_filters => (&return_Nil,) ; 19 | ddt $s, :title<remove Tomatoe 2 filters>, :nl, removal_filters => (&remove_tomatoe, &keep_tomatoe) ; 20 | ddt $s, :title<broken gllyph>, :nl, header_filters => (&remove_tomatoe_header_filter,) ; 21 | ddt $s, :title<container filter 1>, :nl, elements_filters => (&remove_tomatoe_container_filter_1,) ; 22 | ddt $s, :title<container filter 2>, :nl, elements_filters => (&remove_tomatoe_container_filter_2,) ; 23 | 24 | 25 | multi sub remove_tomatoe($dumper, Tomatoe $s, $path) { True } 26 | multi sub return_Nil($dumper, Tomatoe $s, $path) { } 27 | multi sub keep_tomatoe($dumper, Tomatoe $s, $path) { False } 28 | 29 | multi sub remove_tomatoe_header_filter($dumper, \replacement, Tomatoe $s, $, $) 30 | { 31 | replacement = Data::Dump::Tree::Type::Nothing ; 32 | } 33 | 34 | multi sub remove_tomatoe_container_filter_1($dumper, \replacement, Tomatoe $s, $, $) 35 | { 36 | replacement = Data::Dump::Tree::Type::Nothing ; 37 | } 38 | 39 | multi sub remove_tomatoe_container_filter_1( 40 | $dumper, 41 | Array $s, 42 | 43 | ($depth, $glyph, @renderings, ($key, $binder, $value, $path)), 44 | 45 | # elements you can modify 46 | @sub_elements 47 | ) 48 | { 49 | # set/filter the elements 50 | @sub_elements[2]:delete ; 51 | } 52 | 53 | multi sub remove_tomatoe_container_filter_2( 54 | $dumper, 55 | Array $s, 56 | 57 | ($depth, $glyph, @renderings, ($key, $binder, $value, $path)), 58 | 59 | # elements you can modify 60 | @sub_elements 61 | ) 62 | { 63 | # set/filter the elements 64 | @sub_elements[2] = ('tomatoe', '', Data::Dump::Tree::Type::Nothing.new) ; 65 | } 66 | 67 | 68 | -------------------------------------------------------------------------------- /examples/sequences_pairs.pl6: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env perl6 2 | 3 | #use Test ; 4 | #plan 8 ; 5 | 6 | use Data::Dump::Tree ; 7 | use Data::Dump::Tree::ExtraRoles ; 8 | use Data::Dump::Tree::DescribeBaseObjects ; 9 | use Data::Dump::Tree::Diff ; 10 | 11 | my $d = Data::Dump::Tree.new(:compact_width) does DDTR::Diff ; 12 | 13 | $d.dump_synched: (0...*), Seq(2, 3, 'x', 'y') ; 14 | 15 | $d.dump_synched: (0...*), Seq(2, 3, 'x', 'y'), :compact_width ; 16 | $d.dump_synched: (0...^15), Seq(2, 3, 'x', 'y'), :compact_width ; 17 | $d.dump_synched: (0...^10), Seq(2, 3, 'x', 'y'), :compact_width ; 18 | $d.dump_synched: Seq(2, 3, 'x', 'y'), (0...^15), :compact_width ; 19 | 20 | say '' ; say '-' x 30 ; say '' ; 21 | 22 | dd Seq(1, 2, 'x') ; 23 | say (Seq(1, 2, 'x')).gist ; 24 | $d.ddt: Seq(1, 2, 'x') ; 25 | 26 | say '' ; say '-' x 30 ; say '' ; 27 | 28 | dd (1...*) ; 29 | say (1...*).gist ; 30 | $d.ddt: (1...*) ; 31 | 32 | say '' ; say '-' x 30 ; say '' ; 33 | 34 | say (1...10_000).gist ; 35 | $d.ddt: (1...10_000) ; 36 | 37 | class C {has Int $.x = 3} ; 38 | my @a = 1, 2, 3, C.new ; 39 | my @b = <a b c d>; 40 | my \c = @a Z=> @b; 41 | 42 | say '' ; say '-' x 30 ; say '' ; 43 | 44 | my $s = Seq.from-loop(&body, &cond) ; 45 | dd $s ; 46 | say $s.gist ; 47 | 48 | $d.consume_seq<vertical> = False ; 49 | $d.ddt: $s ; 50 | 51 | say '' ; say '-' x 30 ; say '' ; 52 | 53 | $d.consume_seq<vertical> = True ; 54 | $d.ddt: (0...1000) ; 55 | $d.ddt: (0...3) ; 56 | 57 | $d.ddt: (1...*) ; 58 | 59 | $d.consume_seq<consume_lazy> = True ; 60 | $d.ddt: (1...*) ; 61 | 62 | $d.consume_seq<vertical> = False ; 63 | $d.ddt: (1...*) ; 64 | 65 | say '' ; say '-' x 30 ; say '' ; 66 | 67 | # lazy Seq builder 68 | my $x = 0 ; 69 | sub body { state $x = 0.5 ; return $x++ } 70 | sub cond { state $x = 0 ; return False if $x >= 120 ; $x++ ; return True} 71 | 72 | # NQP and much better output from dd even though it consumes the sequence 73 | $d.consume_seq<vertical> = True ; 74 | $d.ddt( c ) ; 75 | 76 | $d.consume_seq<vertical> = False ; 77 | $d.ddt: c ; 78 | dd c ; 79 | say c.gist ; 80 | 81 | my $p = Pair.new(1, 'a') ; 82 | ddt 1 => 'a' ; 83 | 84 | ddt ($p, $p, $p, $p, a => (|< a b c >, ($p,$p))) ; 85 | 86 | dd a => (< a >, b => 2) ; 87 | ddt (a => (< a >, b => 2)) ; 88 | 89 | dd (a => (< a >, b => 2)) ; 90 | ddt (a => (< a >, b => 2)) ; 91 | 92 | dd (a => 2) ; 93 | ddt (a => 2) ; 94 | 95 | dd Pair.new('B', 1) => a => 2 ; 96 | ddt (Pair.new('B', 1) => a => 2) ; 97 | 98 | dd ('B'=> 1 => a => 2) ; 99 | ddt ('B'=> 1 => a => 2) ; 100 | 101 | dd (Pair.new('B', 1) => 1) ; 102 | ddt (Pair.new('B', 1) => 1) ; 103 | 104 | dd ([Pair.new('B', 1), 3] => 2) ; 105 | ddt ([Pair.new('B', 1), 3] => 2) ; 106 | 107 | 108 | 109 | -------------------------------------------------------------------------------- /examples/two_columns.pl6: -------------------------------------------------------------------------------- 1 | 2 | use Data::Dump::Tree ; 3 | use Data::Dump::Tree::MultiColumns ; 4 | 5 | for 6 | ( 7 | (get_dump_lines_integrated([1..4]), get_dump_lines_integrated([6..12]), :width(50)), 8 | (get_dump_lines_integrated([1..4]), get_dump_lines_integrated([6..12])), 9 | (get_dump_lines_integrated([1..4]), get_dump_lines_integrated([6..12]), :width(50), :compact), 10 | (get_dump_lines_integrated([6..12]), get_dump_lines_integrated([1..4])), 11 | (get_dump_lines_integrated([1..7]), get_dump_lines_integrated([4..12]), get_dump_lines_integrated([1..4])), 12 | (<line other_line>, get_dump_lines_integrated([6..12]), get_dump_lines_integrated([1..4])), 13 | (<line other_line>, get_dump_lines_integrated([6..12]), get_dump_lines_integrated([1..4]), :width(20)), 14 | (<line other_line>, get_dump_lines_integrated([6..12]), 1..6, :width(20)), 15 | ((1..4),), 16 | (), 17 | ) 18 | { 19 | my (:@a, :@p) := $_.classify: { $_ !~~ Pair ?? 'a' !! 'p' }; 20 | 21 | say get_columns(|@a, |%(@p)) ; 22 | } 23 | 24 | -------------------------------------------------------------------------------- /examples/untyped_elements.pl6: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env perl6 2 | 3 | use Data::Dump::Tree ; 4 | use Data::Dump::Tree::Enums ; 5 | 6 | # example of filter to remove the type from the rendering 7 | # we only remove type IntStr and derivatives in Arrays in this example 8 | 9 | role my_role { has $.something is rw } # test that Int+something type displays correctly 10 | 11 | my $my_role = my_role.new(:something<more>) ; 12 | 13 | my $i = IntStr.new(5, 'but more') but my_role ; 14 | $i.something = "set to something" ; 15 | 16 | my $d2 = [1, IntStr.new(2, '2'), IntStr.new(3, 'three'), 17 | IntStr.new(4, 'but more') but my_role, 18 | $i, 19 | ] ; 20 | 21 | ddt $d2 ; 22 | ddt $d2, :elements_filters[&untype] ; 23 | 24 | my class NoType { has Int $.val ; method ddt_get_header { $.val, ' ', DDT_FINAL } } 25 | 26 | multi sub untype($dumper, Array $s, $, @elements) 27 | { 28 | @elements .= map: { $_[2].^name ~~ /^IntStr/ ?? (|$_[0,1], NoType.new(:val($_[2]))) !! $_ } 29 | } 30 | 31 | -------------------------------------------------------------------------------- /examples/wrap_and_highlight.pl6: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env perl6 2 | 3 | # transform strings into objects that render in a bit better way 4 | 5 | # .Seq(3) @0 6 | # ├ 0 = Scalar: 1(0).Str 7 | # ├ 1 = Scalar: 10000(5747).Str 8 | # └ 2 = Int: 4238(0).Str 9 | 10 | use Data::Dump::Tree ; 11 | 12 | use Data::Dump::Tree::Enums ; 13 | use Terminal::ANSIColor ; 14 | 15 | class S { has $.a; has $.b ; method ddt_get_header() { $.a ~ '(' ~ $.b ~ ')', '.Scalar', DDT_FINAL } } 16 | sub s ($a, $b) { S.new: :$a, :$b } 17 | 18 | class I { has $.a; has $.b ; method ddt_get_header() { $.a ~ '(' ~ $.b ~ ')', '.Int', DDT_FINAL } } 19 | 20 | multi sub f($dumper, \r, Str $s, ($depth, $path, $glyph, @renderings), (\k, \b, \v, \f, \final, \want_address)) 21 | { 22 | # can replace ourselves with something else, do not forget to update k, b, v, accordingly 23 | # r = < abc def > ; 24 | 25 | if $s ~~ 'parsed' 26 | { 27 | #@renderings.push: (|$glyph, 'Parsed below') ; 28 | 29 | #k = '<my Int> ' ; 30 | #b = '<my b>' ; 31 | v = '123(1)' ; 32 | f = color('bold white on_yellow') ~ '.Parsed' ~ color('reset') ; 33 | final = DDT_FINAL ; 34 | #want_address = True ; 35 | } 36 | } 37 | 38 | ddt :header_filters[&f], (s(5, 6), S.new(:0a, :0b), I.new(:0a, :7b), 'string', 'parsed').Seq ; 39 | ddt :flat(0), :header_filters[&f], (s(5, 6), S.new(:0a, :0b), I.new(:0a, :7b), 'string', 'parsed').Seq ; 40 | 41 | -------------------------------------------------------------------------------- /lib/Data/Dump/Tree/ColorBlobLevel.pm6: -------------------------------------------------------------------------------- 1 | 2 | role DDTR::ColorBlobLevel 3 | { 4 | 5 | method custom_setup 6 | { 7 | $.color = False ; # to let glyph colors bleed to the end of the line 8 | $.glyph_filters.push: &color_blob ; 9 | } 10 | 11 | use Terminal::ANSIColor ; 12 | 13 | has @.blob_colors is rw = < on_230 on_136 on_166 on_160 on_125 on_61 on_33 on_37 on_64 > ; 14 | has @.blob_colors_fg is rw = < 0 > ; 15 | 16 | my $reset_color = (color('reset'), '' , '') ; 17 | 18 | multi sub color_blob($d, $, $depth, $, $, @glyphs, @reset_elements) 19 | { 20 | # return the glyph colored per level, it could be per type, path, ... 21 | 22 | my $color = color( 23 | $d.blob_colors[$depth % $d.blob_colors.elems]) ~ 24 | color($d.blob_colors_fg[$depth % $d.blob_colors_fg.elems] 25 | ) ; 26 | 27 | @glyphs = @glyphs[0], |@glyphs[1..*-1].map({ ($color, |$_[1..2]) }) ; 28 | 29 | @reset_elements.push: $reset_color ; 30 | } 31 | 32 | } # role 33 | 34 | 35 | -------------------------------------------------------------------------------- /lib/Data/Dump/Tree/Colorizer.pm6: -------------------------------------------------------------------------------- 1 | 2 | class Colorizer 3 | { 4 | has %!color_lookup ; 5 | 6 | method set_colors(%colors, $do_color) 7 | { 8 | if $do_color 9 | { 10 | for %colors.kv -> $color_name, $color { %!color_lookup{$color_name} = $.lookup_color($color) } 11 | } 12 | else 13 | { 14 | %!color_lookup = () ; 15 | } 16 | } 17 | 18 | method lookup_color($color_name) { $color_name } 19 | 20 | multi method color(Hash $h, Str $name --> Hash) 21 | { 22 | my %colored_hash ; 23 | 24 | for $h.kv -> $k, $v { %colored_hash{$k} = (%!color_lookup{$name} // '') , $v , %!color_lookup<reset> // ''} 25 | 26 | %colored_hash ; 27 | } 28 | 29 | multi method color(Seq $l, Str $name --> Seq) { $l.map: { (%!color_lookup{$name} // '') , $_ , %!color_lookup<reset> // ''} } 30 | multi method color(List $l, Str $name --> Seq) { $l.map: { (%!color_lookup{$name} // '') , $_ , %!color_lookup<reset> // ''} } 31 | multi method color(Str $string, Str $name --> List) { (%!color_lookup{$name} // '') , $string , %!color_lookup<reset> // ''} 32 | } 33 | 34 | class HtmlColorizer is Colorizer 35 | { 36 | 37 | method lookup_color($color_name) 38 | { 39 | "<font color=$color_name>" 40 | } 41 | 42 | } 43 | 44 | class CursesColorizer is Colorizer 45 | { 46 | 47 | } 48 | 49 | class AnsiColorizer is Colorizer 50 | { 51 | has &.colorizer ; 52 | 53 | method new 54 | { 55 | my &colorizer ; 56 | 57 | if (try require ::Terminal::ANSIColor) !=== Nil 58 | { 59 | &colorizer = ::("Terminal::ANSIColor::EXPORT::ALL::&color") 60 | } 61 | 62 | self.bless(:is_ansi, :colorizer(&colorizer)); 63 | } 64 | 65 | method lookup_color($color_name) 66 | { 67 | &!colorizer ?? &!colorizer($color_name) !! '' 68 | } 69 | 70 | #class 71 | } 72 | 73 | 74 | -------------------------------------------------------------------------------- /lib/Data/Dump/Tree/DHTML.pm6: -------------------------------------------------------------------------------- 1 | 2 | use Data::Dump::Tree ; 3 | use Data::Dump::Tree::Colorizer ; 4 | use Data::Dump::Tree::DescribeBaseObjects ; 5 | 6 | role DDTR::DHTML 7 | { 8 | my $a2h = ( [ "'", '"', '&', '<', '>' ] => [ ''', '"', '&', '<', '>' ] ) ; 9 | my $class_bag = (^10_000).BagHash ; 10 | 11 | method dump_dhtml($s, *%options) is export { say $.get_dhtml_dump($s, |%options) } 12 | 13 | method get_dhtml_dump($s, *%options) is export 14 | { 15 | %options<wrap_data> //= %() ; 16 | my %s := %options<wrap_data> ; 17 | 18 | %s<uuid> = 0 ; 19 | %s<DHTML> //= '' ; 20 | %s<class> //= 'ddt_' ~ $class_bag.grab(1) ; 21 | %s<style_none> //= 0 ; 22 | %s<collapsed> //= False ; 23 | %s<button_collapse> //= True ; 24 | %s<collapse_button_id> //= "%s<class>_button_1" ; 25 | %s<collapse_ids> //= () ; 26 | %s<button_search> //= True ; 27 | %s<search_button_id> //= "%s<class>_button_2" ; 28 | 29 | %s<style> //= qq:to/STYLE/ ; 30 | <style type='text/css'> 31 | .button \{font-family:monospace ; outline: 0 ; width: 150px ; background-color: #303030 ; color: #999999 ; border: none;} 32 | a\{text-decoration: none; white-space: pre; } 33 | .%s<class> li \{list-style-type:none ; margin:0 ; padding:0 ; line-height: 1em ; } 34 | .%s<class> ul \{margin:0 ; padding:0 ;} 35 | ul.%s<class> \{padding:0 ; font-family:monospace ; white-space:nowrap ;} 36 | body \{ background-color: #000000 ;} 37 | </style> 38 | STYLE 39 | 40 | %s<style> = '' if %s<style_none> ; 41 | 42 | qq:to/DHTML/ ; 43 | <?xml version="1.0" encoding="UTF-8"?> 44 | 45 | <meta http-equiv="Content-Type" content="text/html charset=UTF-8"> 46 | 47 | <!DOCTYPE html 48 | PUBLIC "-//W3C//DTD XHTML 1.0 Strict//EN" 49 | "http://www.w3.org/TR/xhtml1/DTD/xhtml1-strict.dtd" 50 | > 51 | 52 | <html> 53 | <!-- Generated by Perl 6 Data::Dumper::Tree::DHTML --> 54 | 55 | <body> 56 | %s<style> 57 | 58 | <div> 59 | { 60 | (%s<button_collapse> 61 | ?? %s<collapsed> 62 | ?? " <input class='button' type='button' id='%s<collapse_button_id>' onclick='expand_collapse_%s<class>\(true)' value='Expand'/>\n" 63 | !! " <input class='button' type='button' id='%s<collapse_button_id>' onclick='expand_collapse_%s<class>\(true)' value='Collapse'/>\n" 64 | !! '') 65 | 66 | ~ # append 67 | 68 | (%s<button_search> 69 | ?? " <input class='button' background-color: #404040 type='button' id='%s<search_button_id>' onclick='search_{%s<class>}()' value='Search'/>\n" 70 | !! '') 71 | } 72 | </div> 73 | 74 | <ul class='{%s<class>}'> 75 | { $.wrap_dump($s, |%options) } 76 | </ul> 77 | 78 | { get_javascript :%s } 79 | 80 | </body> 81 | </html> 82 | DHTML 83 | } 84 | 85 | method wrap_dump($s, *%options) 86 | { 87 | %options<width> = $.width // 1000 ; 88 | 89 | my ($r, $wrap_data) = $.get_dump_lines( 90 | $s, 91 | :wrap_data(%options<wrap_data>), 92 | :wrap_header(&header_wrap), 93 | :wrap_footer(&footer_wrap), 94 | 95 | :colorizer(HtmlColorizer.new), 96 | :colors< 97 | reset "black" 98 | 99 | ddt_address #1010BB link #004000 perl_address #995535 100 | header #aa00aa key #009999 binder #009999 101 | value #a5a5a5 wrap "yellow" 102 | 103 | gl_0 #303030 gl_1 "yellow" gl_2 "green" gl_3 "red" gl_4 "blue" 104 | 105 | kb_0 #d7af00 kb_1 #d78700 106 | kb_2 #0087ff kb_3 #005fff 107 | kb_4 #d787af kb_5 #d75faf 108 | kb_6 #00af00 kb_7 #008700 109 | kb_8 #d70000 kb_9 #af0000 110 | >, 111 | 112 | |%options, 113 | ); 114 | 115 | $wrap_data<DHTML> 116 | } 117 | 118 | my sub header_wrap( 119 | \wd, $rendered_lines, 120 | (@head_glyphs, $glyph, $continuation_glyph, $multi_line_glyph), 121 | (@kvf, @ks, @vs, @fs), 122 | Mu $s, 123 | ($depth, $path, $filter_glyph, @renderings), 124 | ($k, $b, $v, $f, ($ddt_address, $link, $perl_address), $final, $want_address), 125 | ) 126 | { 127 | my ($pad, $pad2) = ( ' ' xx $depth + 1, ' ' xx $depth + 2) ; 128 | my ($class, $uuid) = (wd<class>, wd<class> ~ '_' ~ wd<uuid>) ; 129 | my ($a_uuid, $c_uuid) = ("a_$uuid", "c_$uuid") ; 130 | 131 | my $head_html = @head_glyphs.map( { $_[0] ~ $_[1].trans($a2h) ~ '</font>'} ).join ; 132 | my $head_glyph_html = $head_html ~ $glyph[0] ~ $glyph[1].trans($a2h) ~ '</font>' ; 133 | my $head_continuation_html = $head_html~ $continuation_glyph[0] ~ $continuation_glyph[1].trans($a2h) ~ '</font>' ; 134 | my $head_continuation_multi_html = $head_continuation_html ~ $multi_line_glyph[0] ~ $multi_line_glyph[1] ~ '</font>' ; 135 | 136 | if @kvf 137 | { 138 | my $span = $head_glyph_html ; 139 | 140 | $span ~= @kvf[0].map( { $_[0] ~ $_[1].trans($a2h) ~ '</font>'} ).join ~ '<br>' ; 141 | 142 | if $final 143 | { 144 | wd<DHTML> ~= "$pad\<li><a id='$a_uuid' data-final=1>$span\</a>\n" ; 145 | wd<DHTML> ~= "$pad2\<ul class='$class' id='$c_uuid' style = 'display:none'></ul>\n" 146 | } 147 | else 148 | { 149 | wd<DHTML> ~= "$pad\<li><a id='$a_uuid' href='javascript:void(0);' onclick='toggleList_$class\(\"$c_uuid\", \"$a_uuid\")'>$span\</a>\n" ; 150 | 151 | wd<DHTML> ~= wd<collapsed> 152 | ?? "$pad2\<ul class='$class' id='$c_uuid' style = 'display:none'>\n" 153 | !! "$pad2\<ul class='$class' id='$c_uuid' style = 'display:block'>\n" ; 154 | } 155 | } 156 | else 157 | { 158 | #TODO: add \n to make the generated html readable 159 | 160 | wd<DHTML> ~= "$pad\<li><a id='$a_uuid'" ; 161 | 162 | wd<DHTML> ~= $final 163 | ?? " data-final=1>" 164 | !! " href='javascript:void(0);' onclick='toggleList_$class\(\"$c_uuid\", \"$a_uuid\")'>" ; 165 | 166 | # @ks, @vs, @fs contain a line per entry, each line can be made of multiple components 167 | 168 | if @ks 169 | { 170 | wd<DHTML> ~= $head_glyph_html ; 171 | wd<DHTML> ~= @ks[0].map( { $_[0] ~ $_[1].trans($a2h) ~ '</font>'} ).join ~ '<br>' ; 172 | } 173 | 174 | if @ks > 1 175 | { 176 | for @ks[1..*-1] -> $ks 177 | { 178 | wd<DHTML> ~= $head_continuation_html ; 179 | wd<DHTML> ~= $ks.map( { $_[0] ~ $_[1].trans($a2h) ~ '</font>'} ).join ~ '<br>' ; 180 | } 181 | } 182 | 183 | for @vs -> $vs 184 | { 185 | wd<DHTML> ~= $head_continuation_multi_html ; 186 | wd<DHTML> ~= $vs.map( { $_[0] ~ $_[1].trans($a2h) ~ '</font>'} ).join ~ '<br>' ; 187 | } ; 188 | 189 | for @fs -> $fs 190 | { 191 | #todo: next if $.display_info == False ; 192 | 193 | wd<DHTML> ~= $head_continuation_multi_html ; 194 | wd<DHTML> ~= $fs.map( { $_[0] ~ $_[1].trans($a2h) ~ '</font>'} ).join ~ '<br>' ; 195 | } ; 196 | 197 | wd<DHTML> ~= "</a>\n" ; 198 | 199 | if $final 200 | { 201 | wd<DHTML> ~="$pad2\<ul class='$class' id='$c_uuid' style = 'display:none'></ul>\n" ; 202 | } 203 | else 204 | { 205 | wd<DHTML> ~= wd<collapsed> 206 | ?? "$pad2\<ul class='$class' id='$c_uuid' style = 'display:none'>\n" 207 | !! "$pad2\<ul class='$class' id='$c_uuid' style = 'display:block'\n>" ; 208 | } 209 | } 210 | 211 | wd<uuid>++ ; 212 | } 213 | 214 | my sub footer_wrap(\wd, Mu $s, $final, ($depth, $filter_glyph, @renderings), $wh_token) 215 | { 216 | wd<DHTML> ~= ' ' xx $depth + 2 ~ "</ul>\n" unless $final ; 217 | wd<DHTML> ~= ' ' xx $depth + 1 ~ "</li>\n" ; 218 | } 219 | 220 | my sub get_javascript(:%s) 221 | { 222 | my $class = %s<class> ; 223 | 224 | my $a_ids = (^%s<uuid>).map({ "'a_{%s<class>}_{$_}'" }).join(', ') ; 225 | my $collapsable_ids = (^%s<uuid>).map({ "'c_{%s<class>}_{$_}'" }).join(', ') ; 226 | 227 | my $collapsed = %s<collapsed> ; 228 | 229 | qq:to/EOS/ ; 230 | <script type='text/javascript'> 231 | 232 | function _elem_by_id(id) 233 | \{ 234 | return document.getElementById(id); 235 | } 236 | 237 | function search_{$class}() 238 | \{ 239 | var string_to_search = prompt('DDTR::DHTML Search',''); 240 | var regexp = new RegExp(string_to_search, 'i') ; 241 | 242 | var i ; 243 | for (i = 0 ; i < a_id_array_{$class}.length; i++) 244 | \{ 245 | if(regexp.test(_elem_by_id(a_id_array_{$class}[i]).text)) 246 | \{ 247 | show_specific_node_{$class}(_elem_by_id(a_id_array_{$class}[i])) ; 248 | _elem_by_id(a_id_array_{$class}[i]).style.color = '' ; 249 | _elem_by_id(a_id_array_{$class}[i]).style.backgroundColor = 'cyan' ; 250 | break ; 251 | } 252 | } 253 | 254 | return; 255 | } 256 | 257 | function show_specific_node_{$class} (node) 258 | \{ 259 | collapsed_{$class} = 0; /* hide all */ 260 | expand_collapse_{$class}(); 261 | 262 | do 263 | \{ 264 | node = node.parentNode; 265 | 266 | if (node && node.tagName == 'UL') 267 | node.style.display = 'block'; 268 | 269 | } while (node && node.parentNode); 270 | } 271 | 272 | var a_id_array_{$class}= new Array 273 | ( 274 | $a_ids 275 | ) ; 276 | 277 | var collapsable_id_array_{$class} = new Array 278 | ( 279 | $collapsable_ids 280 | ) ; 281 | 282 | var collapsed_{$class} = { $collapsed ?? 1 !! 0 } ; 283 | 284 | function expand_collapse_{$class}() 285 | \{ 286 | var style ; 287 | if(collapsed_{$class}== 1) 288 | \{ 289 | collapsed_{$class} = 0 ; 290 | color = '' ; 291 | style = "block" ; 292 | replace_button_text("{%s<collapse_button_id>}", "Collapse") ; 293 | } 294 | else 295 | \{ 296 | collapsed_{$class} = 1 ; 297 | color = 'magenta' ; 298 | style = "none" ; 299 | replace_button_text("{%s<collapse_button_id>}", "Expand") ; 300 | } 301 | 302 | var i; 303 | for (i = 0; i < { %s<uuid> } ; i++) 304 | \{ 305 | _elem_by_id(collapsable_id_array_{$class}\[i]).style.display = style ; 306 | _elem_by_id(a_id_array_{$class}[i]).style.backgroundColor = '' ; 307 | 308 | var element = _elem_by_id(a_id_array_{$class}\[i]) ; 309 | var final = element.getAttribute('data-final') ; 310 | if(! final) 311 | \{ 312 | element.style.color = color ; 313 | } 314 | } 315 | } 316 | 317 | function replace_button_text(buttonId, text) 318 | \{ 319 | var button=_elem_by_id(buttonId); 320 | if (button) 321 | \{ 322 | if (button.childNodes[0]) 323 | \{ 324 | button.childNodes[0].nodeValue=text; 325 | } 326 | else if (button.value) 327 | \{ 328 | button.value=text; 329 | } 330 | else //if (button.innerHTML) 331 | \{ 332 | button.innerHTML=text; 333 | } 334 | } 335 | } 336 | 337 | function toggleList_{$class}(tree_id, head_id) 338 | \{ 339 | var element = _elem_by_id(tree_id); 340 | if (element) 341 | \{ 342 | if (element.style.display == 'none') 343 | \{ 344 | element.style.display = 'block'; 345 | element = _elem_by_id(head_id); 346 | element.style.color = '' ; 347 | element.style.backgroundColor = '' ; 348 | } 349 | else 350 | \{ 351 | element.style.display = 'none'; 352 | element = _elem_by_id(head_id); 353 | element.style.color = 'magenta' ; 354 | element.style.backgroundColor = '' ; 355 | } 356 | } 357 | } 358 | 359 | </script> 360 | EOS 361 | } 362 | 363 | 364 | } # role 365 | 366 | 367 | -------------------------------------------------------------------------------- /lib/Data/Dump/Tree/DHTML.pod: -------------------------------------------------------------------------------- 1 | 2 | =begin pod 3 | 4 | =NAME 5 | Date::Dump::Tree::DHTML - Renders structure as DHTML 6 | 7 | =SYNOPSIS 8 | 9 | =DESCRIPTION 10 | 11 | Data::Dump::Tree::DHTML is a Role you can add to a Data::Dump::Tree object. 12 | 13 | The role add a B<dump_dhtml> method to the object. 14 | 15 | =INTERFACE 16 | 17 | =item $dumper.dump_dhtml($s1, *%options) 18 | 19 | Dump a HTML document with folding capacity. 20 | 21 | =item $dumper.get_dhtml_dump($s1, *%options) 22 | 23 | Returns a HTML document with folding capacity on $*OUT. 24 | 25 | =USAGE 26 | 27 | my $d = Data::Dump::Tree.new(title => 'test', does => ( DDTR::DHTML,),) ; 28 | 29 | class Tomato{ has Int $seeds } 30 | $d.dump_dhtml([ 1, { key => { sk1 => 'v1', sk2 => 'v2'},}, Tomato,]) ; 31 | 32 | =head2 Multiple data structures output 33 | 34 | You can call I<dump_dhtml> multiple times for different data structures. Each 35 | dump will have a separate body, class, style, and identifiers. 36 | 37 | =head2 Configuration and Overrides 38 | 39 | Check B<Data::Dump::Tree> for the options that you can pass the dumper. Not all 40 | the standard configurations can be used. 41 | 42 | Generally: 43 | 44 | - all data manipulation done in filters work as the DHTML is generated after the 45 | filters are called 46 | 47 | - data added to @renderings in the filters is not displayed in the dhtml 48 | 49 | - all coloring and format options are ignored 50 | 51 | =head3 Width 52 | 53 | The default width is set to 1_000 characters, you can override it with I<:width>. 54 | 55 | =AUTHOR 56 | 57 | Nadim ibn hamouda el Khemir 58 | https://github.com/nkh 59 | 60 | =LICENSE 61 | 62 | This program is free software; you can redistribute it and/or modify it 63 | under the same terms as Perl6 itself. 64 | 65 | =head1 SEE-ALSO 66 | 67 | Data::Dump::Tree 68 | 69 | =end pod 70 | 71 | DOC INIT {use Pod::To::Text ; pod2text($=pod) ; } 72 | 73 | -------------------------------------------------------------------------------- /lib/Data/Dump/Tree/Ddt.pm6: -------------------------------------------------------------------------------- 1 | 2 | unit module Data::Dump::Tree::Ddt ; 3 | 4 | sub ddt_tp(|args ) is export 5 | { 6 | try 7 | { 8 | require Data::Dump::Tree::TerminalFoldable <&display_foldable> ; 9 | display_foldable |args ; 10 | } 11 | 12 | $!.note if $! ; 13 | } 14 | 15 | sub ddt_remote ($s, :$remote_port is copy, Bool :$counter, |other) is export 16 | { 17 | $remote_port //= 3333 ; 18 | 19 | use experimental :pack; 20 | 21 | try 22 | { 23 | my $c = IO::Socket::INET.new: :host<localhost>, :port($remote_port) ; 24 | my $string = $s.Str ; 25 | 26 | $c.write: pack('N', $string.chars) ; 27 | "sending: {$string.chars}".say if $counter; 28 | 29 | #TODO: substr or Str.rotor (not implemented yet) 30 | for $string.comb.rotor(63 * 1024, :partial) 31 | { 32 | $c.write: $_.join.encode('utf8') ; 33 | } 34 | 35 | $c.close ; 36 | } 37 | 38 | if $! 39 | { 40 | "Error: Can't send below data to port:$remote_port time:{DateTime.now}".note ; 41 | $s.note ; 42 | 43 | return Nil ; 44 | } 45 | else 46 | { 47 | return True ; 48 | } 49 | } 50 | 51 | sub ddt_remote_fold ($s, :$remote_port is copy, Bool :$counter, |other) is export 52 | { 53 | use experimental :pack; 54 | 55 | $remote_port //= 4444 ; 56 | 57 | try 58 | { 59 | require Data::Dump::Tree::TerminalFoldable <&get_foldable> ; 60 | my $f = get_foldable $s, |other ; 61 | 62 | my $c = IO::Socket::INET.new: :host<localhost>, :port($remote_port) ; 63 | 64 | $c.write: pack('N', $f.lines.elems) ; 65 | 66 | for $f.lines 67 | { 68 | my $blob = $_.encode('utf8') ; 69 | $c.write: pack('N', $blob.bytes) ; 70 | $c.write: $blob ; 71 | } 72 | 73 | $c.write: pack('N', $_) for $f.line_lengths ; 74 | $c.write: pack('NNNN', |$_) for $f.folds ; 75 | 76 | $c.close ; 77 | } 78 | 79 | if $! 80 | { 81 | "Error: Can't send data to port:$remote_port time:{DateTime.now}\n$!".note ; 82 | } 83 | } 84 | 85 | 86 | -------------------------------------------------------------------------------- /lib/Data/Dump/Tree/Diff.pm6: -------------------------------------------------------------------------------- 1 | 2 | use Data::Dump::Tree ; 3 | use Data::Dump::Tree::ExtraRoles ; 4 | use Data::Dump::Tree::DescribeBaseObjects ; 5 | 6 | role DDTR::Diff 7 | { 8 | has Bool $diff_glyphs = True ; 9 | has %diff_glyphs = 10 | same_object => '===', 11 | same_type_same_value => 'eqv', 12 | same_type_diff_value => '!= ', 13 | different_type => ' ! ', 14 | same_container => ' ~ ', 15 | diff_container => '!~!', 16 | container_left => ' [r', 17 | container_right => 'l] ', 18 | only_lhs => 'l ', 19 | only_rhs => ' r' ; 20 | 21 | has $diff_synch_filter ; 22 | 23 | method dump_synched($s1, $s2, *%options) 24 | { 25 | $diff_synch_filter = %options<diff_synch_filter> ; 26 | 27 | %.colors<diff1 diff2 diff_glyphs> = ('reset', 'reset', 'reset') ; 28 | 29 | my $color = role { method Str { state $++ %% 2 ?? 'diff1' !! 'diff2' } }.new ; 30 | self.reset ; 31 | 32 | $diff_glyphs [R//]= %options<diff_glyphs> ; 33 | 34 | my $diff_glyph_width = max(%diff_glyphs.values>>.chars) + 2 ; 35 | 36 | my $width = Int(((%options<width> // $.width) - ($diff_glyph_width + 1)) / 2) ; 37 | my $d1 = Data::Dump::Tree.new( 38 | |%options, width => $width, 39 | title => (%options<lhs_title title>:v)[0] // '', 40 | header_filters => %options<header_filters lhs_header_filters>:v, 41 | elements_filters => %options<elements_filters lhs_elements_filters>:v, 42 | footer_filters => %options<footer_filters lhs_footer_filters>:v, 43 | ) ; 44 | 45 | $d1.reset ; #setup object 46 | 47 | my $d2 = Data::Dump::Tree.new( 48 | |%options, width => $width, 49 | title => (%options<rhs_title title>:v)[0] // '', 50 | header_filters => %options<header_filters rhs_header_filters>:v, 51 | elements_filters => %options<elements_filters rhs_elements_filters>:v, 52 | footer_filters => %options<footer_filters rhs_footer_filters>:v, 53 | ) ; 54 | 55 | $d2.reset ; # setup object 56 | 57 | my @diff_glyphs ; 58 | 59 | my $empty_glyph = ('', '', '') ; 60 | my @root_glyphs = 0, |( $empty_glyph xx 5) ; 61 | 62 | $.diff_elements( 63 | # $dumper, $header, $depth, @head_glyphs, @glyphs 64 | $d1, ($d1.get_title, '', $s1, ''), 0, (), @root_glyphs, 65 | @diff_glyphs, 66 | $d2, ($d2.get_title, '', $s2, ''), 0, (), @root_glyphs, 67 | ) ; 68 | 69 | 70 | my ($remove_eqv, $remove_eq) = %options<remove_eqv remove_eq> ; 71 | 72 | if %options<compact_width> 73 | { 74 | my $max_line_width ; 75 | 76 | for $d1.get_renderings Z @diff_glyphs -> ($r1, $dg) 77 | { 78 | next if $remove_eq && $dg eq %diff_glyphs<same_object> ; 79 | next if $remove_eqv && $dg eq %diff_glyphs<same_type_same_value> ; 80 | 81 | $max_line_width max= $r1.map( { $_[1] } ).join.chars ; 82 | } 83 | 84 | $width = min $width, $max_line_width ; 85 | } 86 | 87 | for $d1.get_renderings Z @diff_glyphs Z $d2.get_renderings -> ($r1, $dg is copy, $r2) 88 | { 89 | next if $remove_eq && $dg eq %diff_glyphs<same_object> ; 90 | next if $remove_eqv && $dg eq %diff_glyphs<same_type_same_value> ; 91 | 92 | $dg = '' unless $diff_glyphs ; 93 | 94 | my $r1c = $r1.map( { $_.join } ).join ; 95 | my $r1w = $r1.map( { $_[1] } ).join.chars ; 96 | 97 | my $color_width = $r1c.chars - $r1w ; 98 | 99 | printf "%-{$width + $color_width}s %-{$diff_glyph_width}s %s", 100 | $r1c, 101 | $dg, 102 | $r2.map( { $_.join } ).join ; 103 | 104 | ''.say ; 105 | } 106 | } 107 | 108 | method diff_elements( 109 | $d1, $s1_header, $cd1, $head_glyph1, @glyphs1, 110 | @diff_glyphs, 111 | $d2, $s2_header, $cd2, $head_glyph2, @glyphs2, 112 | ) 113 | { 114 | my ($final1, $rendered1, $s1, $cont_glyph1) = 115 | $d1.render_element($s1_header, $cd1, $head_glyph1, @glyphs1) ; 116 | 117 | my ($final2, $rendered2, $s2, $cont_glyph2) = 118 | $d2.render_element($s2_header, $cd2, $head_glyph2, @glyphs2) ; 119 | 120 | # handle Seq as they get consumed during the diff 121 | my sub cache_seq(Seq $s) 122 | { 123 | my $seq_display_size = $d1.consume_seq<max_element_vertical> ; 124 | my $size = $s.is-lazy ?? ~Inf !! $s.elems ; 125 | 126 | my @l = $s.cache[0..^$seq_display_size].grep({.defined}) ; 127 | @l.push: Data::Dump::Tree::Type::Final.new(:value('..' ~ $size)) if $size > $seq_display_size ; 128 | 129 | @l 130 | } 131 | 132 | $s1 = cache_seq($s1) if $s1 ~~ Seq ; 133 | $s2 = cache_seq($s2) if $s2 ~~ Seq ; 134 | 135 | my ($pad_glyph1, $pad_glyph2) = (|$head_glyph1, @glyphs1[2]), (|$head_glyph2, @glyphs2[2]) ; 136 | 137 | my $diff_glyph = ' ? ' ; 138 | my $is_different = 0 ; 139 | 140 | # handle sub level 141 | if $final1 && !$final2 # different types 142 | { 143 | $diff_glyph = %diff_glyphs<container_left> ; 144 | $d2.render_non_final($s2, $cd2, (|$head_glyph2, $cont_glyph2), $s2_header) unless $rendered2 ; 145 | $is_different++ ; 146 | } 147 | elsif !$final1 && $final2 # different types 148 | { 149 | $diff_glyph = %diff_glyphs<container_right> ; 150 | $d1.render_non_final($s1, $cd1, (|$head_glyph1, $cont_glyph1), $s1_header) unless $rendered1 ; 151 | $is_different++ ; 152 | } 153 | elsif $final1 && $final2 154 | { 155 | $diff_glyph = $s1.^name ~~ $s2.^name 156 | ?? ($s1.WHERE == $s2.WHERE) 157 | ?? %diff_glyphs<same_object> 158 | !! $s1 eqv $s2 159 | ?? %diff_glyphs<same_type_same_value> 160 | !! do { $is_different++ ; %diff_glyphs<same_type_diff_value> } 161 | !! do { $is_different++ ; %diff_glyphs<different_type> } ; 162 | } 163 | else 164 | { 165 | if $s1.^name ~~ $s2.^name 166 | { 167 | if $s1.WHERE == $s2.WHERE 168 | { 169 | $diff_glyph = %diff_glyphs<same_object> ; 170 | $d1.render_non_final($s1, $cd1, (|$head_glyph1, $cont_glyph1), $s1_header) ; 171 | $d2.render_non_final($s2, $cd2, (|$head_glyph2, $cont_glyph2), $s2_header) ; 172 | } 173 | elsif $s1 eqv $s2 174 | { 175 | $diff_glyph = %diff_glyphs<same_type_same_value> ; 176 | $d1.render_non_final($s1, $cd1, (|$head_glyph1, $cont_glyph1), $s1_header) ; 177 | $d2.render_non_final($s2, $cd2, (|$head_glyph2, $cont_glyph2), $s2_header) ; 178 | } 179 | else 180 | { 181 | $diff_glyph = %diff_glyphs<same_container> ; 182 | 183 | synch_renderings( 184 | $d1.get_renderings, $pad_glyph1, 185 | $d2.get_renderings, $pad_glyph2, 186 | @diff_glyphs, $diff_glyph, 187 | ) ; 188 | 189 | my $index = @diff_glyphs.end ; # may have to change the glyph after rendering sub levels 190 | 191 | my (@sub_elements1, %glyphs1) := $d1.get_sub_elements($s1, $cd1, (|$head_glyph1, $cont_glyph1), $s1_header) ; 192 | my (@sub_elements2, %glyphs2) := $d2.get_sub_elements($s2, $cd2, (|$head_glyph2, $cont_glyph2), $s2_header) ; 193 | 194 | if $diff_synch_filter 195 | { 196 | $diff_synch_filter( 197 | $s1, @sub_elements1, $cd1, $d1.get_renderings, (|$head_glyph1, $cont_glyph1), 198 | @diff_glyphs, 199 | $s2, @sub_elements2, $cd2, $d2.get_renderings, (|$head_glyph2, $cont_glyph2), 200 | ) ; 201 | } 202 | else 203 | { 204 | if $s1 ~~ Hash and $s2 ~~ Hash 205 | { 206 | my %h1 = @sub_elements1.map: { $_[0] => $_ } ; 207 | ($s2.keys (-) $s1.keys).map: { %h1{$_.key} = ('', '!', Data::Dump::Tree::Type::Nothing.new) } ; 208 | @sub_elements1 = %h1.sort(*.key)>>.kv.map: -> ($k, $v) { $v } 209 | 210 | my %h2 = @sub_elements2.map: { $_[0] => $_ } ; 211 | ($s1.keys (-) $s2.keys).map: { %h2{$_.key} = ('', '!', Data::Dump::Tree::Type::Nothing.new) } ; 212 | @sub_elements2 = %h2.sort(*.key)>>.kv.map: -> ($k, $v) { $v } 213 | } 214 | } 215 | 216 | for zipi(@sub_elements1, @sub_elements2) -> ($index, $sub1, $sub2) 217 | { 218 | my $sub_element_glyphs1 = $d1.get_element_glyphs(%glyphs1, $index == @sub_elements1.end) ; 219 | my $sub_element_glyphs2 = $d2.get_element_glyphs(%glyphs2, $index == @sub_elements2.end) ; 220 | 221 | if $sub1.defined && $sub2.defined 222 | { 223 | $is_different += $.diff_elements( 224 | $d1, $sub1, $cd1 + 1, (|$head_glyph1, $cont_glyph1), $sub_element_glyphs1, 225 | @diff_glyphs, 226 | $d2, $sub2, $cd2 + 1, (|$head_glyph2, $cont_glyph2), $sub_element_glyphs2, 227 | ) ; 228 | } 229 | elsif $sub1.defined 230 | { 231 | $is_different++ ; 232 | $diff_glyph = %diff_glyphs<only_lhs> ; 233 | $d1.render_element_structure($sub1, $cd1 + 1, (|$head_glyph1, $cont_glyph1), $sub_element_glyphs1) ; 234 | } 235 | else 236 | { 237 | $is_different++ ; 238 | $diff_glyph = %diff_glyphs<only_rhs> ; 239 | $d2.render_element_structure($sub2, $cd2 + 1, (|$head_glyph1, $cont_glyph2), $sub_element_glyphs2) ; 240 | } 241 | } 242 | 243 | @diff_glyphs[$index] = %diff_glyphs<same_type_same_value> unless $is_different ; 244 | } 245 | } 246 | else 247 | { 248 | # different type but equivalent 249 | if $s1 eqv $s2 250 | { 251 | $diff_glyph = %diff_glyphs<same_type_same_value> ; 252 | 253 | $d1.render_non_final($s1, $cd1, (|$head_glyph1, $cont_glyph1), $s1) unless $rendered1 ; 254 | $d2.render_non_final($s2, $cd2, (|$head_glyph2, $cont_glyph2), $s2) unless $rendered2 ; 255 | } 256 | else 257 | { 258 | $diff_glyph = %diff_glyphs<diff_container> ; 259 | $d1.render_non_final($s1, $cd1, (|$head_glyph1, $cont_glyph1), $s1) unless $rendered1 ; 260 | $d2.render_non_final($s2, $cd2, (|$head_glyph2, $cont_glyph2), $s2) unless $rendered2 ; 261 | $is_different++ ; 262 | } 263 | } 264 | } 265 | 266 | # footer filter 267 | $d1.footer_filters and $s1.WHAT !=:= Mu and 268 | $d1.filter_footer($s1, ($cd1, (|$head_glyph1, $cont_glyph1), $d1.get_renderings)) ; 269 | 270 | $d2.footer_filters and $s2.WHAT !=:= Mu and 271 | $d2.filter_footer($s2, ($cd2, (|$head_glyph2, $cont_glyph2), $d2.get_renderings)) ; 272 | 273 | synch_renderings( 274 | $d1.get_renderings, $pad_glyph1, 275 | $d2.get_renderings, $pad_glyph2, 276 | @diff_glyphs, $diff_glyph, 277 | ) ; 278 | 279 | $is_different ; 280 | } 281 | 282 | sub synch_renderings(@r1, $p1, @r2, $p2, @d, $dg) 283 | { 284 | @r1.append: $p1 xx @r2.elems - @r1.elems ; 285 | @r2.append: $p2 xx @r1.elems - @r2.elems ; 286 | @d.append: $dg xx @r1.elems - @d.elems ; 287 | } 288 | 289 | sub zipi(**@as) 290 | { 291 | my @zip ; 292 | 293 | (^max @as.map: {$_.elems}).map: -> $index 294 | { 295 | @zip.append: $[ $index, |(@as.map: { $_[$index] }) ], ; 296 | } 297 | 298 | @zip 299 | } 300 | 301 | 302 | #role 303 | } 304 | 305 | -------------------------------------------------------------------------------- /lib/Data/Dump/Tree/Diff.pod: -------------------------------------------------------------------------------- 1 | 2 | =begin pod 3 | 4 | =NAME 5 | 6 | Date::Dump::Tree::Diff - Renders two data structures in synch 7 | 8 | =SYNOPSIS 9 | 10 | =DESCRIPTION 11 | 12 | Data::Dump::Tree::Diff is a Role you can add to a Data::Dump::Tree object 13 | 14 | The role add a B<dump_synched> method to the object that can: 15 | 16 | =item can display two data structures side by side 17 | 18 | =item can display the difference between two data structures 19 | 20 | 21 | =INTERFACE 22 | 23 | =item method get_synched_dump($s1, $s2, *%options) 24 | 25 | Dumps of the synchronized structures on the terminal 26 | 27 | =USAGE 28 | 29 | $d.dump_synched( 30 | # data structures to dump 31 | %df1,%df2, 32 | 33 | #options to be used on both sides of the dump 34 | does => (DDTR::MatchDetails,), color_glyphs => True, 35 | 36 | #options specific to the synchronized dump 37 | diff_glyphs => False, compact_width => True, 38 | remove_eq => True, remove_eqv => True) ; 39 | 40 | =head2 Output example 41 | 42 | {8} @0 ~ {7} @0 43 | |- A => {5} @1 === |- A => {5} @1 44 | | |- a => 1 / "1".IntStr === | |- a => 1 / "1".IntStr 45 | | |- b => 2 / "2".IntStr === | |- b => 2 / "2".IntStr 46 | | |- c => 3 / "3".IntStr === | |- c => 3 / "3".IntStr 47 | | |- d => {1} @2 === | |- d => {1} @2 48 | | | `- x => {1} @3 === | | `- x => {1} @3 49 | | | `- y => 1 / "1".IntStr === | | `- y => 1 / "1".IntStr 50 | | `- e => 1.Int === | `- e => 1.Int 51 | |- B => {3} @4 ~ |- B => {5} @4 = @1 52 | | |- a => 1 / "1".IntStr eqv | |- a => 1 / "1".IntStr 53 | | |- b => 2 / "2".IntStr eqv | |- b => 2 / "2".IntStr 54 | | |- c => 3 / "3".IntStr eqv | |- c => 3 / "3".IntStr 55 | | |- d (-) [r | |- d => {1} @5 = @2 56 | | `- e (-) ! | `- e => 1.Int 57 | |- C => {3} @5 eqv |- C => {3} @6 58 | | |- a => 1 / "1".IntStr eqv | |- a => 1 / "1".IntStr 59 | | |- b => 2 / "2".IntStr eqv | |- b => 2 / "2".IntStr 60 | | `- c => 3 / "3".IntStr eqv | `- c => 3 / "3".IntStr 61 | |- D => 0.3 (3/10).Rat ! |- D => hi.Str 62 | |- E => 1.Int != |- E => 2.Int 63 | |- F => 2.Int [r |- F => {3} @7 64 | | [r | |- a => 1 / "1".IntStr 65 | | [r | |- b => 2 / "2".IntStr 66 | ... 67 | 68 | =head2 Configuration and Overrides 69 | 70 | Check B<Data::Dump::Tree> for the options that you can pass the dumper. The 71 | same options will be used on both sides of the dump. All the Data::Dump::Tree 72 | options are valid 73 | 74 | =head3 title 75 | 76 | You can eiter set the title for both sides simulteanously or for each side 77 | using: 78 | 79 | =item lhs_title 80 | 81 | =item rhs_title 82 | 83 | =head3 Width 84 | 85 | By default the terminal width will be divided in two, minus the room for 86 | the diff glyphs column. You can also set option I<width> or use 87 | 88 | =item compact_width 89 | 90 | Put the two data structures as close to each other as possible 91 | 92 | The default glyphs are: 93 | 94 | same_object => '===', 95 | same_type_same_value => 'eqv', 96 | same_type_diff_value => '!= ', 97 | different_type => ' ! ', 98 | same_container => ' ~ ', 99 | diff_container => '!~!', 100 | container_left => ' [r', 101 | container_right => 'l] ', 102 | only_lhs => 'l ', 103 | only_rhs => ' r' ; 104 | 105 | =item diff_glyphs 106 | 107 | You can set this option to False if you do not want the diff glyph column 108 | to be displayed. 109 | 110 | =head3 Displaying only the difference between the data structures 111 | 112 | Below is an example where only different elements are displayed; the diff 113 | glyphs column was also removed from the dump. The example can be found in 114 | I<examples/diff>. 115 | 116 | {8} @0 {7} @0 117 | |- B => {3} @4 |- B => {5} @4 = @1 118 | | |- d (-) | |- d => {1} @5 = @2 119 | | `- e (-) | `- e => 1.Int 120 | |- D => 0.3 (3/10).Rat |- D => hi.Str 121 | |- E => 1.Int |- E => 2.Int 122 | |- F => 2.Int |- F => {3} @7 123 | | | |- a => 1 / "1".IntStr 124 | | | |- b => 2 / "2".IntStr 125 | | | `- c => 3 / "3".IntStr 126 | |- G => {1} @6 |- G (-) 127 | | `- a => 1 / "1".IntStr | 128 | 129 | You can set 130 | 131 | =item remove_eq 132 | 133 | set if you want the to remove from the display the objects that are exactly 134 | the same in both data structures. 135 | 136 | =item remove_eqv 137 | 138 | set if you want the to remove from the display the objects that are equivalent 139 | in both data structures. 140 | 141 | =head3 data structure filters 142 | 143 | you can set U<header_filters>, U<elements_filters>, and U<footer_filters> as 144 | described in U<Data::Dump::Tree> documentation. 145 | 146 | You can also specify filters that are specific to a side of the diff 147 | 148 | =item rhs_header_filters and lhs_header_filters 149 | 150 | =item rhs_elements_filters and lhs_elements_filters 151 | 152 | =item rhs_footer_filters and lhs_footer_filters 153 | 154 | =head3 diff synchronization filter 155 | 156 | I<Data::Dump::Tree::Diff> synchronizes Hashes, if you want to synch other type 157 | of data you can set 158 | 159 | =item diff_synch_filter 160 | 161 | Note that you will have to synch Hashes too if you want to keep them ordered 162 | properly. 163 | 164 | =AUTHOR 165 | 166 | Nadim ibn hamouda el Khemir 167 | https://github.com/nkh 168 | 169 | =LICENSE 170 | 171 | This program is free software; you can redistribute it and/or modify it 172 | under the same terms as Perl6 itself. 173 | 174 | =head1 SEE-ALSO 175 | 176 | Data::Dump::Tree 177 | 178 | =end pod 179 | 180 | DOC INIT {use Pod::To::Text ; pod2text($=pod) ; } 181 | 182 | -------------------------------------------------------------------------------- /lib/Data/Dump/Tree/Enums.pm6: -------------------------------------------------------------------------------- 1 | 2 | enum DDT_Final (DDT_NOT_FINAL => 0, 'DDT_FINAL') ; 3 | 4 | enum DDT_Address (DDT_HAS_NO_ADDRESS => 0, 'DDT_HAS_ADDRESS') ; 5 | enum DDT_Address_Display (DDT_DISPLAY_NONE => 0, 'DDT_DISPLAY_ALL', 'DDT_DISPLAY_CONTAINER') ; 6 | 7 | enum DDT_Stage (DDT_HEADER => 0, 'DDT_SUB_ELEMENTS', 'DDT_FOOTER') ; 8 | 9 | -------------------------------------------------------------------------------- /lib/Data/Dump/Tree/ExtraRoles.pm6: -------------------------------------------------------------------------------- 1 | 2 | use Data::Dump::Tree::Enums ; 3 | use Data::Dump::Tree::DescribeBaseObjects ; 4 | 5 | role DDTR::MatchStringLimit does DDTR::StringLimiter 6 | { 7 | has $.match_string_limit is rw = 10 ; 8 | 9 | multi method get_header (Match:D $m) 10 | { 11 | ($.limit_string(~$m, $.match_string_limit), Q/[/ ~ $m.from ~ '..' ~ $m.to -1 ~ ']', DDT_FINAL) 12 | } 13 | 14 | } #role 15 | 16 | 17 | role DDTR::MatchDetails does DDTR::StringLimiter 18 | { 19 | 20 | has $.match_string_limit is rw ; 21 | 22 | multi method get_header (Match:U $m) { '', '.' ~ $m.^name, DDT_FINAL } 23 | multi method get_header (Match:D $m) 24 | { 25 | return ('', '[no match]', DDT_FINAL) if $m.pos == 0 ; 26 | 27 | $m.caps.elems 28 | ?? ($.limit_string(~$m, $.match_string_limit), Q/[/ ~ $m.from ~ '..' ~ $m.to - 1 ~ ']') 29 | !! ($.limit_string(~$m, $.match_string_limit), Q/[/ ~ $m.from ~ '..' ~ $m.to -1 ~ ']', DDT_FINAL, DDT_HAS_ADDRESS) 30 | 31 | } 32 | 33 | multi method get_elements (Match $m) 34 | { 35 | $m.caps>>.kv.map: -> ($k, $v) { ( "<$k>", ' ', $v ) } 36 | } 37 | 38 | } # role 39 | 40 | 41 | #`{{ 42 | # role to display Match internals, commented out so we don't waste time compiling it 43 | 44 | use Data::Dump::Tree ; 45 | role DDTR::MatchObject does DDTR::StringLimiter 46 | { 47 | # displays type as .Match and details about Match object 48 | has $.match_string_limit is rw ; 49 | 50 | multi method get_header (Match:U $m) { '', '.' ~ $m.^name, DDT_FINAL } 51 | multi method get_header (Match:D $m) 52 | { 53 | $m.caps.elems 54 | ?? ( $.limit_string(~$m, $.match_string_limit), Q/[/ ~ $m.from ~ '..' ~ $m.to ~ '|' ) 55 | !! ( $.limit_string(~$m, $.match_string_limit), Q/[/ ~ $m.from ~ '..' ~ $m.to ~ '|', DDT_FINAL, DDT_HAS_ADDRESS ) 56 | } 57 | 58 | multi method get_elements (Match $m) { get_attributes($m) } 59 | 60 | } #role 61 | }} 62 | 63 | role DDTR::FixedGlyphs 64 | { 65 | has $.fixed_glyph = ' ' ; 66 | 67 | multi method get_glyphs 68 | { 69 | { 70 | last => $.fixed_glyph, not_last => $.fixed_glyph, 71 | last_continuation => $.fixed_glyph, not_last_continuation => $.fixed_glyph, 72 | multi_line => $.fixed_glyph, empty => ' ' x $.fixed_glyph.chars, max_depth => '...', 73 | filter => $.fixed_glyph, 74 | } 75 | } 76 | 77 | } #role 78 | 79 | role DDTR::NumberedLevel 80 | { 81 | 82 | method get_level_glyphs($level, Bool $root? = False) 83 | { 84 | my %glyphs = $.get_glyphs() ; 85 | 86 | my $superscript_level = $.superscribe($level) ; 87 | 88 | for <last not_last> { %glyphs{$_} = $superscript_level ~ ' ' ~ %glyphs{$_} } 89 | for <last_continuation not_last_continuation multi_line empty> 90 | { %glyphs{$_} = ' ' x $superscript_level.chars ~ ' ' ~ %glyphs{$_} } 91 | 92 | my $glyph_width = %glyphs<empty>.chars + $superscript_level.chars ; 93 | 94 | # multiline glyph is on the next level, color accordingly 95 | my $multi_line = %glyphs<multi_line> ; 96 | 97 | my %colored_glyphs = $.colorizer.color(%glyphs, @.glyph_colors_cycle[$level]) ; 98 | 99 | $root 100 | ?? (%colored_glyphs<multi_line> = $.colorizer.color($multi_line, @.glyph_colors_cycle[0])) 101 | !! (%colored_glyphs<multi_line> = $.colorizer.color($multi_line, @.glyph_colors_cycle[$level + 1])) ; 102 | 103 | %colored_glyphs<__width> = $glyph_width ; #squirel in the width 104 | 105 | %colored_glyphs 106 | } 107 | 108 | } #role 109 | 110 | 111 | # superscribe below 112 | 113 | my @ssl ; 114 | 115 | for ( 116 | < … . ( ) + - = @ [ ] | { } > , (|< ⁻ · ⁽ ⁾ ⁺ ⁻ ⁼ >, '', ' ', '', '', '', '' ), 117 | ('0'..'9') , < ⁰ ¹ ² ³ ⁴ ⁵ ⁶ ⁷ ⁸ ⁹ >, 118 | ('a'..'z') , < ᵃ ᵇ ᶜ ᵈ ᵉ ᶠ ᵍ ʰ ⁱ ʲ ᵏ ˡ ᵐ ⁿ ᵒ ᵖ ᵠ ʳ ˢ ᵗ ᵘ ᵛ ʷ ˣ ʸ ᶻ >, 119 | ('A'..'Z') , < ᴬ ᴮ ᶜ ᴰ ᴱ ᶠ ᴳ ᴴ ᴵ ᴶ ᴷ ᴸ ᴹ ᴺ ᴼ ᴾ ᵠ ᴿ ˢ ᵀ ᵁ ⱽ ᵂ ˣ ʸ ᶻ >, 120 | ) 121 | -> $A, $s { @ssl[|$A.map: {.ord}] = |$s } 122 | 123 | sub do_superscribe($text) { ($text.comb.map: { @ssl[$_.ord] // $_}).join } 124 | 125 | role DDTR::SuperscribeBase 126 | { 127 | method do_superscribe($text) { ($text.comb.map: { @ssl[$_.ord] // $_}).join } 128 | } 129 | 130 | role DDTR::SuperscribeAddress does DDTR::SuperscribeBase 131 | { 132 | method superscribe($text) { $.do_superscribe($text) } 133 | method superscribe_address($text) { $.do_superscribe($text) } 134 | } 135 | 136 | role DDTR::SuperscribeType does DDTR::SuperscribeBase 137 | { 138 | method superscribe($text) { $.do_superscribe($text) } 139 | method superscribe_type($text) { $.do_superscribe($text) } 140 | } 141 | 142 | role DDTR::Superscribe does DDTR::SuperscribeBase 143 | { 144 | method superscribe($text) { $.do_superscribe($text) } 145 | method superscribe_address($text) { $.do_superscribe($text) } 146 | method superscribe_type($text) { $.do_superscribe($text) } 147 | } 148 | 149 | -------------------------------------------------------------------------------- /lib/Data/Dump/Tree/Horizontal.pm6: -------------------------------------------------------------------------------- 1 | 2 | use Data::Dump::Tree ; 3 | use Data::Dump::Tree::Enums ; 4 | use Data::Dump::Tree::MultiColumns ; 5 | 6 | class Data::Dump::Tree::Horizontal 7 | { 8 | 9 | =begin pod 10 | 11 | =NAME 12 | Date::Dump::Tree::Horizontal - wrap an object to render it horizontally 13 | 14 | =SYNOPSIS 15 | 16 | # sub elements filter 17 | sub ($d, $s, ($depth, $glyph, @renderings, $), @sub_elements) 18 | { 19 | if $depth == 2 20 | { 21 | my $total_width = $d.width - (($depth + 2 ) * 3) ; 22 | 23 | @sub_elements = 24 | ( 25 | ( 26 | '', 27 | '', 28 | # render the current element's data horizontally 29 | Data::Dump::Tree::Horizontal.new(:dumper($d), :elements(@elements)), 30 | ), 31 | ) 32 | } 33 | } 34 | 35 | See I<examples/horizontal> in the distribution for multiple examples 36 | 37 | =DESCRIPTION 38 | 39 | Data::Dump::Tree::Horizontal renders the sub elements of the element it wraps 40 | separately, and aligns them horizontally. 41 | 42 | 43 | # normal rendering of a List 44 | (3) @0 45 | ├ 0 = 1.Int 46 | ├ 1 = 3.Int 47 | └ 2 = 4.Int 48 | 49 | # rendering wrapped in Data::Dump::Tree::Horizontal 50 | (3) @0 51 | 0 = 1.Int 1 = 3.Int 2 = 4.Int 52 | 53 | 54 | # normal rendering of a longer List 55 | (4) @0 56 | ├ 0 = [2] @1 57 | │ ├ 0 = [2] @2 58 | │ │ ├ 0 = 1.Int 59 | │ │ └ 1 = [2] @3 60 | │ │ ├ 0 = 2.Int 61 | │ │ └ 1 = [2] @4 62 | │ │ ├ 0 = 3.Int 63 | │ │ └ 1 = 4.Int 64 | │ └ 1 = [2] §2 65 | ├ 1 = [2] @6 66 | │ ├ 0 = [3] @7 67 | │ │ ├ 0 = 1.Int 68 | │ │ ├ 1 = 2.Int 69 | │ │ └ 2 = .Pair @8 70 | │ │ └ k:3, v:[2] @9 71 | │ │ ├ 0 = 4.Int 72 | │ │ └ 1 = 5.Int 73 | │ └ 1 = .Seq(11) @10 74 | │ ├ 0 = [2] §2 75 | │ ├ 1 = [2] §2 76 | │ ├ 2 = [2] §2 77 | │ ├ 3 = [2] §2 78 | │ ├ 4 = [2] §2 79 | │ ├ 5 = [2] §2 80 | │ ├ 6 = [2] §2 81 | │ ├ 7 = [2] §2 82 | │ ├ 8 = [2] §2 83 | │ ├ 9 = [2] §2 84 | │ └ ... 85 | ├ 2 = 12345678.Str 86 | └ 3 = [2] §6 87 | 88 | # rendering in horizontal layout 89 | (4) @0 90 | 0 = [2] @1 1 = [2] @6 2 = 12345678.Str 3 = [2] §6 91 | ├ 0 = [2] @2 ├ 0 = [3] @7 92 | │ ├ 0 = 1.Int │ ├ 0 = 1.Int 93 | │ └ 1 = [2] @3 │ ├ 1 = 2.Int 94 | │ ├ 0 = 2.Int │ └ 2 = .Pair @8 95 | │ └ 1 = [2] @4 │ └ k:3, v:[2] @9 96 | │ ├ 0 = 3.Int │ ├ 0 = 4.Int 97 | │ └ 1 = 4.Int │ └ 1 = 5.Int 98 | └ 1 = [2] §2 └ 1 = .Seq(11) @10 99 | ├ 0 = [2] §2 100 | ├ 1 = [2] §2 101 | ├ 2 = [2] §2 102 | ├ 3 = [2] §2 103 | ├ 4 = [2] §2 104 | ├ 5 = [2] §2 105 | ├ 6 = [2] §2 106 | ├ 7 = [2] §2 107 | ├ 8 = [2] §2 108 | ├ 9 = [2] §2 109 | └ ... 110 | 111 | =INTERFACE 112 | 113 | =item method new: :element($s), [ :other_named_arguments, ...] 114 | 115 | =head2 Arguments 116 | 117 | =item :elements 118 | 119 | The elements to wrap,they will be rendered horizontally, in columns 120 | 121 | =item :title 122 | 123 | Title to be displayed over the sub elements renderings 124 | 125 | =item :total_width 126 | 127 | The maximum width the horizontal rendering can take, the rendering will be 128 | wrapped into multiple rows 129 | 130 | =item :rows 131 | 132 | columnize the flattened output with this many rows in each column. 133 | 134 | =item :dumper 135 | 136 | The dumper to be used to render the sub elements, Passing a dumper allows the 137 | referenced to match between columns. You want to pass the dumper of the top 138 | container for the best results. A new dumper is created if this is not set. 139 | 140 | =item :flat_depth 141 | 142 | Options passed between renderers to handle lower renderers starting at depth 143 | zero while in the top rendering context they are at lower levels 144 | 145 | =AUTHOR 146 | 147 | Nadim ibn hamouda el Khemir 148 | https://github.com/nkh 149 | 150 | =LICENSE 151 | 152 | This program is free software; you can redistribute it and/or modify it 153 | under the same terms as Perl6 itself. 154 | 155 | =head1 SEE-ALSO 156 | 157 | Data::Dump::Tree 158 | 159 | DDT::MultiColumns 160 | 161 | =end pod 162 | 163 | has Str $.title = '' ; 164 | has Int $.width ; 165 | has Int $.total_width ; 166 | has Int $.rows ; 167 | has Data::Dump::Tree $.dumper ; 168 | has @.elements ; 169 | has $.flat_depth ; 170 | 171 | method ddt_get_header 172 | { 173 | #`{{ 174 | my @blocks = @!elements.map: -> ($k, $b, $sub_element) 175 | { 176 | $!dumper.get_dump_lines_integrated: 177 | $sub_element, 178 | :title( S/(' ')$// given $k ~ $b ) , 179 | :width($.total_width), 180 | :address_from($!dumper), 181 | :flat_depth($.flat_depth + 1), 182 | :!nl, 183 | :indent('') ; 184 | } 185 | }} 186 | 187 | my @blocks = @!elements.map: -> @element 188 | { 189 | $!dumper.get_dump_lines_integrated: 190 | @element[2], 191 | :title( S/(' ')$// given @element[0] ~ @element[1] ) , 192 | :width($.total_width), 193 | :address_from($!dumper), 194 | :flat_depth($.flat_depth + 1), 195 | :!nl, 196 | :indent('') ; 197 | } 198 | 199 | my $columns ; 200 | 201 | with $.rows 202 | { 203 | my @columns = $[] ; 204 | 205 | for @blocks -> $block 206 | { 207 | @columns.push: [] if @columns[*-1].elems >= $.rows ; 208 | 209 | my $column = @columns[*-1] ; 210 | 211 | if $column.elems + $block.elems > $.rows 212 | { 213 | if $column.elems > 0 214 | { 215 | $column.push: '' xx $.rows - $column.elems ; 216 | @columns.push: [ |$block ] ; 217 | } 218 | else 219 | { 220 | $column.push: |$block ; 221 | } 222 | } 223 | else 224 | { 225 | $column.push: |$block ; 226 | } 227 | 228 | if $column.elems >= $.rows 229 | { 230 | $column.push: '' ; 231 | } 232 | } 233 | 234 | $columns = get_columns :$!total_width, :$!width, |@columns 235 | } 236 | else 237 | { 238 | $columns = get_columns :$!total_width, :$!width, |@blocks ; 239 | $columns ~= "\n" ; 240 | } 241 | 242 | ($!title ne '' ?? "$!title\n" !! '') ~ $columns, '', DDT_FINAL 243 | } 244 | 245 | 246 | } #class 247 | 248 | DOC INIT {use Pod::To::Text ; pod2text($=pod) ; } 249 | 250 | 251 | -------------------------------------------------------------------------------- /lib/Data/Dump/Tree/LayHorizontal.pm6: -------------------------------------------------------------------------------- 1 | 2 | use Data::Dump::Tree::Horizontal ; 3 | 4 | unit module Data::Dump::Tree::LayHorizontal ; 5 | 6 | =begin pod 7 | 8 | =NAME 9 | Date::Dump::Tree::LayHorizontal - layout data in horizontal or column mode 10 | 11 | =SYNOPSIS 12 | use Data::Dump::Tree ; 13 | 14 | ddt $some_complex_data, :flat(Array) ; 15 | 16 | See I<examples/flat.pl> in the distribution for multiple examples 17 | 18 | =DESCRIPTION 19 | 20 | Renders data elements matching :flat conditions in a horizontal or columns 21 | layout ; this allows you to mix vertical and horizontal layout in the same 22 | rendering. 23 | 24 | =head1 Horizontal layout 25 | 26 | Vertical layout: 27 | (6) @0 28 | ├ 0 = [3] @1 29 | │ ├ 0 = [2] @2 30 | │ │ ├ 0 = 1.Int 31 | │ │ └ 1 = [2] @3 32 | │ │ ├ 0 = 2.Int 33 | │ │ └ 1 = [2] @4 34 | │ │ ├ 0 = 3.Int 35 | │ │ └ 1 = 4.Int 36 | │ ├ 1 = (1) @5 37 | │ │ └ 0 = [2] @6 38 | │ │ ├ 0 = 6.Int 39 | │ │ └ 1 = [1] @7 40 | │ │ └ 0 = 3.Int 41 | │ └ 2 = [2] §2 42 | ├ 1 = [2] @9 43 | │ ├ 0 = [2] §2 44 | │ └ 1 = [2] §2 45 | ├ 2 = [2] @12 46 | │ ├ 0 = [2] @13 47 | │ │ ├ 0 = 1.Int 48 | │ │ └ 1 = 2.Int 49 | │ └ 1 = .Seq(11) @14 50 | │ ├ 0 = [2] §2 51 | │ ├ 1 = [2] §2 52 | │ ├ 2 = [2] §2 53 | │ ├ 3 = [2] §2 54 | │ ├ 4 = [2] §2 55 | │ ├ 5 = [2] §2 56 | │ ├ 6 = [2] §2 57 | │ ├ 7 = [2] §2 58 | │ ├ 8 = [2] §2 59 | │ ├ 9 = [2] §2 60 | │ └ ... 61 | ├ 3 = [10] @25 62 | │ ├ 0 = [2] §2 63 | │ ├ 1 = [2] §2 64 | │ ├ 2 = [2] §13 65 | │ ├ 3 = [3] @29 66 | │ │ ├ 0 = 1.Int 67 | │ │ ├ 1 = 2.Int 68 | │ │ └ 2 = 3.Int 69 | │ ├ 4 = [2] §2 70 | │ ├ 5 = [2] §2 71 | │ ├ 6 = [2] §2 72 | │ ├ 7 = [2] §2 73 | │ ├ 8 = [2] §2 74 | │ └ 9 = [2] §2 75 | ├ 4 = [2] §12 76 | └ 5 = 12345678.Str 77 | 78 | dd's output for comparison: 79 | 80 | $($[[1, [2, [3, 4]]], ([6, [3]],), [1, [2, [3, 4]]]], [[1, [2, [3, 4]]], [1, [2, [3 81 | , 4]]]], $[[1, 2], ([1, [2, [3, 4]]], [1, [2, [3, 4]]], [1, [2, [3, 4]]], [1, [2, [ 82 | 3, 4]]], [1, [2, [3, 4]]], [1, [2, [3, 4]]], [1, [2, [3, 4]]], [1, [2, [3, 4]]], [1 83 | , [2, [3, 4]]], [1, [2, [3, 4]]], [1, [2, [3, 4]]]).Seq], [[1, [2, [3, 4]]], [1, [2 84 | , [3, 4]]], [1, 2], [1, 2, 3], [1, [2, [3, 4]]], [1, [2, [3, 4]]], [1, [2, [3, 4]]] 85 | , [1, [2, [3, 4]]], [1, [2, [3, 4]]], [1, [2, [3, 4]]]], $[[1, 2], ([1, [2, [3, 4]] 86 | ], [1, [2, [3, 4]]], [1, [2, [3, 4]]], [1, [2, [3, 4]]], [1, [2, [3, 4]]], [1, [2, 87 | [3, 4]]], [1, [2, [3, 4]]], [1, [2, [3, 4]]], [1, [2, [3, 4]]], [1, [2, [3, 4]]], [ 88 | 1, [2, [3, 4]]]).Seq], "12345678") 89 | 90 | Rendered horizontally with :flat(0) 91 | 92 | (6) @0 93 | 0 = [3] @1 1 = [2] @9 2 = [2] @12 3 = [10] @25 94 | ├ 0 = [2] @2 ├ 0 = [2] §2 ├ 0 = [2] @13 ├ 0 = [2] §2 95 | │ ├ 0 = 1.Int └ 1 = [2] §2 │ ├ 0 = 1.Int ├ 1 = [2] §2 96 | │ └ 1 = [2] @3 │ └ 1 = 2.Int ├ 2 = [2] §13 97 | │ ├ 0 = 2.Int └ 1 = .Seq(11) @14 ├ 3 = [3] @29 98 | │ └ 1 = [2] @4 ├ 0 = [2] §2 │ ├ 0 = 1.Int 99 | │ ├ 0 = 3.Int ├ 1 = [2] §2 │ ├ 1 = 2.Int 100 | │ └ 1 = 4.Int ├ 2 = [2] §2 │ └ 2 = 3.Int 101 | ├ 1 = (1) @5 ├ 3 = [2] §2 ├ 4 = [2] §2 102 | │ └ 0 = [2] @6 ├ 4 = [2] §2 ├ 5 = [2] §2 103 | │ ├ 0 = 6.Int ├ 5 = [2] §2 ├ 6 = [2] §2 104 | │ └ 1 = [1] @7 ├ 6 = [2] §2 ├ 7 = [2] §2 105 | │ └ 0 = 3.Int ├ 7 = [2] §2 ├ 8 = [2] §2 106 | └ 2 = [2] §2 ├ 8 = [2] §2 └ 9 = [2] §2 107 | ├ 9 = [2] §2 108 | └ ... 109 | 4 = [2] §12 5 = 12345678.Str 110 | 111 | =head1 Column layout 112 | 113 | If you just flatten, the elements will be rendered after each other. If it 114 | reaches the maximum width, a new row is started. 115 | 116 | In the example below you can see how the elements of the Array are listed after 117 | each other. 118 | 119 | While listing Hashes is better horizontally, Arrays tend to look better in 120 | columns layout giving them a table look. 121 | 122 | I<:flat(Array)> 123 | 124 | (3) @0 125 | ├ 0 = [10] @1 126 | │ 0 = 1.Int 1 = 2.Int 2 = 3.Int 3 = 4.Int 4 = 5.Int 5 = 6.Int 127 | │ 6 = 7.Int 7 = 8.Int 8 = 9.Int 9 = 10.Int 128 | │ 129 | ├ 1 = [11] @2 130 | │ 0 = 1.Int 1 = 2.Int 2 = 3.Int 3 = 4.Int 4 = 5.Int 5 = 6.Int 131 | │ 6 = 7.Int 7 = 8.Int 8 = 9.Int 9 = 10.Int 10 = [10] @3 132 | │ ├ 0 = 1.Int 133 | │ ├ 1 = 2.Int 134 | │ ├ 2 = 3.Int 135 | │ ├ 3 = 4.Int 136 | │ ├ 4 = 5.Int 137 | │ ├ 5 = 6.Int 138 | │ ├ 6 = 7.Int 139 | │ ├ 7 = 8.Int 140 | │ ├ 8 = 9.Int 141 | │ └ 9 = 10.Int 142 | │ 143 | └ 2 = {2} @4 144 | ├ a => 1 / "1".IntStr 145 | └ b => 2 / "2".IntStr 146 | 147 | 148 | Rather then listing all the elements after each other, you can ask for sets of 149 | elements to be rendered in columnar layout and then after each other. 150 | 151 | I<:flat((Array,5),> 152 | 153 | (3) @0 154 | ├ 0 = [10] @1 155 | │ 0 = 1.Int 5 = 6.Int 156 | │ 1 = 2.Int 6 = 7.Int 157 | │ 2 = 3.Int 7 = 8.Int 158 | │ 3 = 4.Int 8 = 9.Int 159 | │ 4 = 5.Int 9 = 10.Int 160 | │ 161 | ├ 1 = [11] @2 162 | │ 0 = 1.Int 5 = 6.Int 10 = [10] @3 163 | │ 1 = 2.Int 6 = 7.Int ├ 0 = 1.Int 164 | │ 2 = 3.Int 7 = 8.Int ├ 1 = 2.Int 165 | │ 3 = 4.Int 8 = 9.Int ├ 2 = 3.Int 166 | │ 4 = 5.Int 9 = 10.Int ├ 3 = 4.Int 167 | │ ├ 4 = 5.Int 168 | │ ├ 5 = 6.Int 169 | │ ├ 6 = 7.Int 170 | │ ├ 7 = 8.Int 171 | │ ├ 8 = 9.Int 172 | │ └ 9 = 10.Int 173 | │ 174 | └ 2 = {2} @4 175 | ├ a => 1 / "1".IntStr 176 | └ b => 2 / "2".IntStr 177 | 178 | =INTERFACE 179 | 180 | =item :flat(...) 181 | 182 | I<:flat> takes a list of conditions and options to allow you to control what 183 | is flattened. 184 | 185 | =head2 Conditions 186 | 187 | =item blocks: :flat({ $_ ~~ Array && $_.elems > 15 }, ...) 188 | 189 | You can pass Blocks to I<:flat>, they are called for each object in your data 190 | structure,this lets you dynamically choose if you want the data in horizontal 191 | , columns or vertical layout. 192 | 193 | In the above example Arrays with more than 15 elements are flattened. 194 | 195 | Inside your block: 196 | 197 | =over 2 198 | 199 | =item $_ is a reference to the data being rendered 200 | 201 | =item $*d is the depth at which the data is 202 | 203 | =back 204 | 205 | The pointy block returns list of three elements 206 | 207 | =over 2 208 | 209 | =item Bool, lay flat or not 210 | 211 | =item Int, nuber of rows in a colums 212 | 213 | =item Int, minimum width of an entry 214 | 215 | =back 216 | 217 | =item integer: :flat(0) or :flat 218 | 219 | Will flatten at the given level in your data structure. 220 | 221 | =item object: :flat($object, $object2, ..) 222 | 223 | If $object, $object2, ... are found in the data structure, they will be 224 | flattened, this allows a selective flattening. 225 | 226 | =item object type: :flat(Array, List, ...) 227 | 228 | Will flatten any object in your data structure that matches one of the types 229 | passed as a condition. Flattening Hashes looks particularly good. 230 | 231 | =item other conditions are smart-matched 232 | 233 | =head2 Columns 234 | 235 | Splitting uses the same interface as the conditions but rather than pass a 236 | condition, you pass a list consisting of a condition and split value. 237 | 238 | ddt $data, :flat(Array) ; 239 | 240 | ddt $data, :flat( (Array, 5) ) ; 241 | 242 | I<Sub> conditions can dynamically return a split value. 243 | 244 | ddt $data, :flat( { $_ ~~ Array andthen True, 5} ) 245 | 246 | You can also pass a minimum column value: 247 | 248 | ddt $data, :flat( { $_ ~~ Array andthen True, 5, 10} ) 249 | 250 | =AUTHOR 251 | 252 | Nadim ibn hamouda el Khemir 253 | https://github.com/nkh 254 | 255 | =LICENSE 256 | 257 | This program is free software; you can redistribute it and/or modify it 258 | under the same terms as Perl6 itself. 259 | 260 | =head1 SEE-ALSO 261 | 262 | Data::Dump::Tree 263 | 264 | =end pod 265 | 266 | sub match_target(@targets, $s, $depth) 267 | { 268 | my (Bool $matched, Int $rows, Int $width) ; 269 | 270 | for @targets -> $target is copy 271 | { 272 | ($target, $rows) = $target if $target.^name eq 'List' ; 273 | 274 | if $target ~~ Block 275 | { 276 | my $*d = $depth ; 277 | my ($st, $ss, $sr) = $target($s) ; 278 | 279 | if $st 280 | { 281 | $ss andthen $rows = $ss ; 282 | $sr andthen $width = $sr ; 283 | 284 | $matched = True ; 285 | last 286 | } 287 | } 288 | 289 | # Int can only match depth 290 | if $target ~~ Int { $matched = $depth == $target ; last } 291 | 292 | if $target ~~ (Array:D | Hash:D | List:D) && $s === $target 293 | { $matched = True ; last } 294 | 295 | if $target ~~ none( Pair | Block | Hash:D | Array:D | List:D) && $s ~~ $target 296 | { $matched = True ; last } 297 | 298 | $rows = Int ; # reset if no match 299 | } 300 | 301 | $matched, $rows, $width 302 | } 303 | 304 | sub lay_horizontal(@targets) is export 305 | { 306 | return 307 | # a DDT sub elements filter 308 | sub ($d, $s, ($depth, $glyph, @renderings, $), @sub_elements) 309 | { 310 | my ($matched, $rows, $width) = match_target(@targets, $s, $d.flat_depth + $depth) ; 311 | 312 | if $matched 313 | { 314 | my $total_width = $d.width - (($depth + 2 ) * 3) ; 315 | 316 | @sub_elements = ( 317 | ( 318 | '', 319 | '', 320 | Data::Dump::Tree::Horizontal.new: 321 | :dumper($d.address_from // $d), 322 | :elements(@sub_elements), 323 | :$rows, 324 | :$width, 325 | :$total_width, 326 | :flat_depth($depth), 327 | ), 328 | ) ; 329 | } 330 | } 331 | } 332 | 333 | 334 | 335 | -------------------------------------------------------------------------------- /lib/Data/Dump/Tree/MultiColumns.pm6: -------------------------------------------------------------------------------- 1 | 2 | 3 | =begin pod 4 | 5 | =NAME 6 | Date::Dump::Tree::MultiColums - Tabulates lists of text 7 | 8 | =SYNOPSIS 9 | use Data::Dump::Tree::Horizontal ; 10 | 11 | display_columns <1 2 3>, my_get_lines(), :named_option, ... 12 | 13 | See I<examples/two_colums> in the distribution for multiple examples 14 | 15 | =DESCRIPTION 16 | 17 | Given a list of string lists, return a tabulated version of the input lists. 18 | 19 | use Data::Dump::Tree ; 20 | use Data::Dump::Tree::MultiColumns ; 21 | 22 | display_columns <line other_line>, get_dump_lines_integrated([6..12]), 1..6, :width(20) ; 23 | 24 | Output: 25 | 26 | line [7] @0 1 27 | other_line ├ 0 = 6.Int 2 28 | ├ 1 = 7.Int 3 29 | ├ 2 = 8.Int 4 30 | ├ 3 = 9.Int 5 31 | ├ 4 = 10.Int 6 32 | ├ 5 = 11.Int 33 | └ 6 = 12.Int 34 | 35 | 36 | =INTERFACE 37 | 38 | =item sub display_columns($text_list, $text_list, ... , Int :total_width, Int :width, Bool :compact --> Str) 39 | 40 | 'say's the rendered text 41 | 42 | =item sub get_columns($text_list, $text_list, ... , Int :total_width, Int :width, Bool :compact --> Str) 43 | 44 | Returns the rendered text 45 | 46 | =head2 Arguments 47 | 48 | =item list of text lists 49 | 50 | Both subs take a variable number of string lists 51 | 52 | =item :total_width 53 | 54 | The maximum width of the output, multiple rows of columns will be generated if necessary 55 | 56 | =item :width 57 | 58 | The minimum width of each colum 59 | 60 | =item :compact 61 | 62 | Set the width of each column to fit the column's content. It will override I<:width> 63 | 64 | =AUTHOR 65 | 66 | Nadim ibn hamouda el Khemir 67 | https://github.com/nkh 68 | 69 | =LICENSE 70 | 71 | This program is free software; you can redistribute it and/or modify it 72 | under the same terms as Perl6 itself. 73 | 74 | =head1 SEE-ALSO 75 | 76 | Data::Dump::Tree 77 | 78 | =end pod 79 | 80 | sub display_columns(**@rs, Int :$total_width, Int :$width, Bool :$compact) is export 81 | { 82 | print get_columns(|@rs, :$total_width, :$width, :$compact) ; 83 | } 84 | 85 | my regex COLOR { \[ \d+ [\;\d+]* <?before [\;\d+]* > m } 86 | 87 | my role MaxLines { has $.max_lines is rw = 0 } 88 | 89 | sub get_columns(**@rs, Int :$total_width, Int :$width, Bool :$compact --> Str) is export 90 | { 91 | return '' unless @rs ; 92 | 93 | my $current_length = 0 ; 94 | my $current_block = [] but MaxLines ; 95 | my $current_block_max_length = 0 ; 96 | my @blocks = $current_block ; 97 | 98 | for |@rs 99 | { 100 | my @lines_width ; 101 | my $elements = $_.elems ; 102 | 103 | # compute width without ANSI escape codes 104 | my $r_max_width = (.map: { my $w = S:g/ \e <COLOR> //.chars ; @lines_width.push: $w ; $w }).max ; 105 | 106 | my $r_width = $compact ?? $r_max_width !! max $width // 0, $r_max_width ; 107 | 108 | if $total_width.defined && $current_length + $r_width >= $total_width 109 | { 110 | $current_length = 0 ; 111 | $current_block = [] but MaxLines ; 112 | @blocks.push: $current_block ; 113 | } 114 | 115 | $current_block.max_lines max= $elements ; 116 | $current_length += $r_width + 1 ; # joined with a single space later 117 | $current_block.push: $r_width, @lines_width, $_ ; 118 | } 119 | 120 | my $o = '' ; 121 | 122 | for @blocks -> @block 123 | { 124 | for ^@block.max_lines -> $index 125 | { 126 | my $string ; 127 | 128 | for @block -> $width, $width_lines, $lines 129 | { 130 | $string ~= $index < $lines.elems 131 | ?? $lines[$index] ~ (' ' x $width - $width_lines[$index]) ~ ' ' 132 | !! ' ' x $width ~ ' ' ; 133 | } 134 | 135 | $o ~= $string ~ "\n" ; 136 | } 137 | } 138 | 139 | $o ; 140 | } 141 | 142 | 143 | DOC INIT { use Pod::To::Text ; pod2text($=pod) } 144 | 145 | -------------------------------------------------------------------------------- /lib/Data/Dump/Tree/TerminalFoldable.pm6: -------------------------------------------------------------------------------- 1 | 2 | unit module Data::Dump::Tree::TerminalPrint ; 3 | 4 | =begin pod 5 | 6 | =NAME Data::Dump::Tree::TerminalPrint 7 | 8 | =SYNOPSIS 9 | 10 | use Data::Dump::Tree::TerminalPrint ; 11 | 12 | display_foldable([ [ [ 1 ] ], ], :debug, :title<first>) ; 13 | 14 | =DESCRIPTION 15 | 16 | Display a rendered data structure in a Terminal::Print window. 17 | 18 | You cam navigate the structure and fold it's elements. 19 | 20 | =head1 display_foldable($data, :$debug, :$debug_column, *%options) ; 21 | 22 | =AUTHOR 23 | 24 | Nadim ibn hamouda el Khemir 25 | https://github.com/nkh 26 | 27 | =LICENSE 28 | 29 | This program is free software; you can redistribute it and/or modify it 30 | under the same terms as Perl6 itself. 31 | 32 | =head1 SEE-ALSO 33 | 34 | Terminal::Print 35 | 36 | =end pod 37 | 38 | use Data::Dump::Tree ; 39 | use Data::Dump::Tree::Foldable ; 40 | 41 | use Terminal::Print ; 42 | use Terminal::Print::DecodedInput; 43 | 44 | 45 | sub get_foldable ($s, *%options) is export 46 | { 47 | Data::Dump::Tree::Foldable.new: 48 | $s, 49 | |%options, 50 | :width_minus(5) ; 51 | } 52 | 53 | multi sub display_foldable ($s, :$page_height is copy, :$debug, :$debug_column, *%options) is export 54 | { 55 | display_foldable(get_foldable $s, |%options, :$page_height, :$debug, :$debug_column) ; 56 | } 57 | 58 | multi sub display_foldable (Data::Dump::Tree::Foldable $f, :$page_height is copy, :$debug, :$debug_column, *%options) is export 59 | { 60 | 61 | my ($ph, $page_width) = ((qx[stty size] || '0 80') ~~ /(\d+) \s+ (\d+)/).List ; 62 | 63 | $page_height //= +$ph ; 64 | $page_height max= +$ph ; 65 | 66 | my $g = $f.get_view ; $g.set: :page_size($page_height) ; 67 | 68 | my Bool $refresh = True ; 69 | 70 | class Tick { } 71 | my $timer = Supply.interval(2).map: { Tick } ; 72 | my $in-supply = decoded-input-supply; 73 | 74 | my $supplies = Supply.merge($in-supply, $timer) ; 75 | 76 | my $screen = Terminal::Print.new ; 77 | $screen.initialize-screen ; 78 | 79 | my sub refresh 80 | { 81 | if $refresh 82 | { 83 | display($screen, $g, :$page_height, :$page_width) ; 84 | debug($screen, $g, :$debug_column) if $debug ; 85 | } 86 | } 87 | 88 | refresh ; 89 | 90 | react 91 | { 92 | whenever $supplies 93 | { 94 | when Tick { ; } # Timer Tick 95 | 96 | when 'q' { done } # Quit 97 | 98 | when 'r' { $g = $f.get_view ; $g.set: :page_size($page_height) ; $refresh++ ; refresh ; } 99 | when 'a' { $refresh = $g.fold_all ; refresh ; } 100 | when 'u' { $refresh = $g.unfold_all ; refresh ; } 101 | 102 | when 'e' { $refresh = $g.selected_line_up ; refresh ; } 103 | when 'd' { $refresh = $g.selected_line_down ; refresh ; } 104 | 105 | when CursorUp { $refresh = $g.line_up ; refresh ; } 106 | when CursorDown { $refresh = $g.line_down ; refresh ; } 107 | when PageUp { $refresh = $g.page_up ; refresh ; } 108 | when PageDown { $refresh = $g.page_down ; refresh ; } 109 | 110 | when CursorLeft { $refresh = $g.fold_flip_selected ; refresh ; } 111 | when CursorRight { $refresh = $g.fold_flip_selected ; refresh ;} 112 | 113 | when Home { $refresh = $g.home ; refresh ; } 114 | when End { $refresh = $g.end ; refresh ; } 115 | } 116 | } 117 | 118 | $screen.shutdown-screen ; 119 | } 120 | 121 | # --------------------------------------------------------------------------------- 122 | 123 | sub display($screen, $g, :$page_height, :$page_width) 124 | { 125 | my @lines = $g.get_lines ; 126 | 127 | for @lines Z 0..* -> ($line, $index) 128 | { 129 | my ($text, $length) = ($line[2], $line[3]) ; 130 | 131 | print $screen.cell-string(0, $index) 132 | ~ ($g.selected_line == $index ?? '> ' !! ' ') 133 | ~ ($line[1] ?? '* ' !! ' ') 134 | ~ $text 135 | ~ (' ' x ($page_width - ($length + 5)) ) ; 136 | } 137 | 138 | my $blank = ' ' x ($page_width - 1) ; 139 | for @lines.elems..($page_height - 1) 140 | { 141 | print $screen.cell-string(0, $_) ~ $blank ; 142 | } 143 | 144 | } 145 | 146 | # --------------------------------------------------------------------------------- 147 | 148 | sub debug ($screen, $geometry, :$debug_column) 149 | { 150 | my @lines = get_dump_lines $geometry, 151 | :title<Geometry>, :!color, :!display_info, :does(DDTR::AsciiGlyphs,), 152 | :header_filters( 153 | sub ($dumper, \r, $s, ($, $path, @glyphs, @renderings), (\k, \b, \v, \f, \final, \want_address)) 154 | { 155 | # remove foldable object 156 | r = Data::Dump::Tree::Type::Nothing if k ~~ /'$.foldable'/ ; 157 | 158 | # tabulate the folds data 159 | if k ~~ /'@.folds'/ 160 | { 161 | try 162 | { 163 | require Text::Table::Simple <&lol2table> ; 164 | 165 | r = lol2table( 166 | < top index next start lines folds folded parent >, 167 | ($s.List Z 0..*).map: -> ($d, $i) 168 | { 169 | [ $geometry.top_line == $i ?? '*' !! '', $i, |$d] 170 | }, 171 | ).join("\n") ; 172 | } 173 | 174 | @renderings.push: "$!" if $! ; 175 | } 176 | }) ; 177 | 178 | for @lines Z 0..* -> ($line, $index) 179 | { 180 | $screen.print-string: $debug_column // 30, $index, $line.map( {$_.join} ).join ; 181 | } 182 | } 183 | 184 | -------------------------------------------------------------------------------- /t/00_use.t: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env perl6 2 | 3 | use Test; 4 | use Data::Dump::Tree; 5 | 6 | plan 1; 7 | 8 | ok True, 'can use'; 9 | 10 | -------------------------------------------------------------------------------- /t/01_all.t: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env perl6 2 | 3 | use Test ; 4 | plan 1 ; 5 | 6 | use Data::Dump::Tree ; 7 | use Data::Dump::Tree::Enums ; 8 | 9 | class Strings 10 | { 11 | 12 | method ddt_get_header { "say something about this class\nmultiline", '.' ~ self.^name ~ "\n multiline classes" } 13 | method ddt_get_elements 14 | { 15 | ('', '', 'has no name'), 16 | ("very very long\nexplanation on multiple lines\n", '', "many lines\n" x 5), 17 | ('single-long', ': ', 'x' x 300), 18 | ('multiple-long', ': ', 'x' x 300 ~ "\n" ~ 'y' x 200), 19 | 20 | ('12345678901234567890123456789012345', '', [ 1, {a => 3} ]), 21 | ("12345678901234567890123456789012345\nxxx", '', 'test'), 22 | 23 | ('coefficient', ' = ', 1), 24 | } 25 | 26 | #class 27 | } 28 | 29 | # class with elements and methods but has not type handler nor DDT specific methods 30 | class GenericClass { has $.x ; has $!z ; method zz {} } 31 | role GenericRole { has $.role } 32 | role Whatnot { has $.whatnot is rw = 13 } 33 | 34 | class Dog { has $.name; } 35 | role DescribeDog 36 | { 37 | 38 | multi method get_header (Dog $d) 39 | { 40 | 'Woof! ', '.Dog (but this one is vagrant, no address)', DDT_NOT_FINAL, DDT_HAS_NO_ADDRESS 41 | } 42 | 43 | multi method get_elements (Dog $d) { (q/the dog's name is/, ': ', $d.name), } 44 | 45 | } 46 | 47 | class Hermit {} 48 | class LivesUnderRock {} 49 | 50 | class Shy is Hermit is LivesUnderRock { has $.in_object } 51 | role DescribeShy { multi method get_elements (Shy $d) { ('Role{DescribeShy} ', '', 1), } } 52 | role DescribeShyFinal { multi method get_header (Shy $d) { 'Role{DescribeShyFinal} ', '.' ~ $d.^name, DDT_FINAL } } 53 | 54 | class Mangled 55 | { 56 | method ddt_get_elements { ('inner structure', ' => ', [123, 456]), } 57 | } 58 | 59 | # ------------- test -------------- 60 | 61 | my $d = Data::Dump::Tree.new ; 62 | $d does DescribeDog ; 63 | $d does DescribeShyFinal ; 64 | 65 | my $dump = $d.ddt: 66 | :get, 67 | get_test_structure(), 68 | title =>'test data', 69 | max_depth => 3, 70 | display_perl_address => True, 71 | width => 75, 72 | :!color ; 73 | 74 | is( $dump.lines.elems, 81, 'all lines') or diag $dump ; 75 | 76 | # ------------- helpers ------------- 77 | 78 | sub get_test_structure 79 | { 80 | my $nil is default(Nil) = Nil; 81 | my @a = 1 ; 82 | my $b = [< a >] ; 83 | my $list = < a b > ; 84 | my $sub = sub (Int $a, Str $string) {} 85 | my Routine $routine ; 86 | 87 | my $s = [ 88 | 'text', 89 | Str, 90 | 12, 91 | Int, 92 | Rat.new(31, 10), 93 | $sub, 94 | $routine, 95 | [], 96 | @a, 97 | $b, 98 | @a, 99 | $b, 100 | $list, 101 | { 102 | default_nil => $nil, 103 | Nil => Nil, 104 | a => 1, 105 | b => 'string', 106 | }, 107 | Cool.new(), 108 | (GenericClass.new(:x(5), :z('hi there')) does GenericRole) but Whatnot, 109 | Mangled.new(), 110 | Dog.new(name => 'fido'), 111 | Shy.new(secret => 'I will not say'), 112 | Strings.new(), 113 | #regex 114 | 'aaa' ~~ m:g/(a)/, 115 | ] ; 116 | 117 | $s ; 118 | } 119 | 120 | 121 | -------------------------------------------------------------------------------- /t/03_multiple_arguments.t: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env perl6 2 | 3 | use Test ; 4 | plan 4 ; 5 | 6 | use Data::Dump::Tree ; 7 | use Data::Dump::Tree::ExtraRoles ; 8 | 9 | my $d = Data::Dump::Tree.new: :!color ; 10 | 11 | my $dump = $d.ddt: :get, :!color ; 12 | is $dump.lines.elems, 0, '0 line' or diag $dump ; 13 | is $dump, '', 'error' or diag $dump ; 14 | 15 | 16 | $dump = $d.ddt: :get, 1, :!color ; 17 | is $dump.lines.elems, 1, '1 line' or diag $dump ; 18 | 19 | $dump = $d.ddt: :get, 1, 2, 3, :!color, 4, 5, (12, 3) ; 20 | is $dump.lines.elems, 8, '8 line' or diag $dump ; 21 | 22 | -------------------------------------------------------------------------------- /t/04_flat.t: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env perl6 2 | 3 | use Data::Dump::Tree ; 4 | 5 | use Test ; 6 | plan 23 ; 7 | 8 | my @a = [4..5] ; 9 | my $d = [[[[1..2],[3..4],],]] ; 10 | my %h1 = <c 3> ; 11 | my %h2 = <a 1 b 2> ; 12 | my $s = ([1..3], %h1, %h2, @a) ; 13 | 14 | my %h3 = <a 1 b 2 c 3 d 4> ; 15 | my @a2 = [1..10] ; 16 | my $d2 = ([1..10], [|(1..10), @a2 ], %h3) ; 17 | 18 | my $d3 = ([1..10], [|(1..10), [|(1..22), %h1, %h2,%h2, |(23..30), [1..6], |(1..4)] ], {some => {a => 1, b => [|(1..5), %h1]}, thing => $s}) ; 19 | 20 | for 21 | ( 22 | (13, :title<test 10, string>, $s, :flat(10, <hello>)), 23 | (13, :title<test [1..3]>, $s, :flat([1..3],)), 24 | (14, :title<test Hash>, $s, :flat(Hash,)), 25 | (6, :title<test flat:>, $s, :flat), 26 | (6, :title<test 0>, $s, :flat(0)), 27 | (13, :title<test 1>, $s, :flat(1)), 28 | (11, :title<test 2>, ($d, [3..5]), :flat(2)), 29 | (14, :title<test 3>, ($d, [3..5], $d), :flat(3)), 30 | (13, :title<<test %(a => 1, b => 2)>>, $s, :flat(%(a => 1, b => 2),)), 31 | (14, :title<test %h1>, $s, :flat(%h1,)), 32 | (13, :title<test @a>, $s, :flat(@a,)), 33 | (14, :title<test sub: Hash>, $s, :flat({$_ ~~ Hash})), 34 | (12, :title<test sub Array $s.first: 3>, $s, :flat({$_ ~~ Array && $_.first: 3})), 35 | (14, :title<test sub: $s == %h1>, $s, :flat({$_ === %h1})), 36 | # columns 37 | (39, :title<flat()>, $d2, :flat()), 38 | (38, :title<flat((H, 2))>, $d2, :flat((Hash, 2),)), 39 | (23, :title<flat((sA, 2))>, $d2, :flat(({$_ ~~ Array && $*d == 1}, 2), )), 40 | (26, :title<flat((sA, L1, *5) 2)>, $d2, :flat(({$_ ~~ Array && $*d == 1, 5}, 2), )), 41 | (35, :title<flat((sA, L2, *5) 2)>, $d2, :flat(({$_ ~~ Array && $*d == 2, 5}, 2), )), 42 | (35, :title<flat((s@a2, L2, *5) 2)>, $d2, :flat(({$_ === @a2 && $*d == 2, 5}, 2), )), 43 | (35, :title<flat((sA, L2, *5) 2)>, $d2, :flat({$_ ~~ Array && $*d == 2, 5}, )), 44 | (22, :title<flat((sA, *5) 2)>, $d2, :flat(({$_ ~~ Array, 5}, 2), )), 45 | 46 | # hash flatten if more than two keys, if less only if keys are non final 47 | # array guess number of columns based on the number of elements and left space and rendering, which we know nothing about :) 48 | (48, :title<d3, flat(H, sA-5)>, $d3, :flat({$_ ~~ Hash && $_.keys > 1}, {$_ ~~ Array && $_.elems > 5, 5} )), 49 | ) 50 | { 51 | my ($lines, $title, $ds, $flat) = | $_ ; 52 | my Capture $c = \(|$title, $ds, |$flat) ; 53 | 54 | my $r = ddt :get_lines_integrated, |$c, :width(80), :!color ; 55 | is($r.elems, $lines) or do 56 | { 57 | diag ddt :get, |$title, $ds ; 58 | #diag ddt :get, |$c, :width(80) ; 59 | 60 | diag $r.join("\n") ; 61 | } 62 | } 63 | 64 | -------------------------------------------------------------------------------- /t/05_class_attributes.t: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env perl6 2 | 3 | use Test ; 4 | plan 4 ; 5 | 6 | 7 | use Data::Dump::Tree ; 8 | use Data::Dump::Tree::DescribeBaseObjects ; 9 | class MyClass { has Int $.size ; has Str $.name } 10 | 11 | my $s = MyClass.new: :size(6), :name('P6 class') ; 12 | 13 | my $dump = ddt :get, $s, :!color, does => (DDTR::AsciiGlyphs,) ; 14 | 15 | like $dump.lines[0], /'.MyClass'/, 'class name' or diag $dump ; 16 | like $dump.lines[1], /'$.size = 6 '/, 'Int attribute' or diag $dump ; 17 | like $dump.lines[2], /'$.name = P6 class.Str'/, 'Str attribute' or diag $dump ; 18 | is $dump.lines.elems, 3, '3 lines dump' or diag $dump ; 19 | 20 | -------------------------------------------------------------------------------- /t/06_role_attributes.t: -------------------------------------------------------------------------------- 1 | 2 | use Test ; 3 | use Data::Dump::Tree ; 4 | 5 | plan 11 ; 6 | 7 | class edible { has $taste = 1 / 3 ; } 8 | class Fruit is edible { has $.seeds } 9 | role Tomato {has $.color = 'red'} ; 10 | 11 | role E { has Fruit $fruit = Fruit.new(:seeds(3)) but Tomato ; } 12 | 13 | for 14 | ( 15 | (1, 2, 3), 16 | [1..3], 17 | %( <a 1 b 2 > ), 18 | 42, 19 | 'string', 20 | False, 21 | IntStr.new(42, 'fourty two'), 22 | 1/3, 23 | (1..3), 24 | (1..*), 25 | (1 => []), 26 | ) 27 | { 28 | my $dump = ddt :get, $_ but E, :!color ; 29 | like $dump, /'$.color +{Tomato}'/, 'role done' or diag $dump ; 30 | } 31 | 32 | 33 | -------------------------------------------------------------------------------- /t/10_role.t: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env perl6 2 | 3 | use Test ; 4 | use Data::Dump::Tree ; 5 | use Data::Dump::Tree::DescribeBaseObjects ; 6 | 7 | plan 5 ; 8 | 9 | my $d = Data::Dump::Tree.new does DDTR::AsciiGlyphs ; 10 | 11 | class C { has $.in_object = 'in_object' } 12 | 13 | my $dump = $d.ddt: :get, C.new, color => False ; 14 | like $dump, /in_object/, 'default dumper' ; 15 | 16 | $d does role { multi method get_elements (C $c) { [('Role{1}', '', 1),] }} 17 | $dump = $d.ddt: :get, C.new , color => False ; 18 | 19 | like $dump, /Role\{1\}/, 'first role' ; 20 | is $dump.lines.elems, 2, '2 lines dump' or diag $dump ; 21 | 22 | $d does role { multi method get_elements (C $c) { [('Role{2}', '', 2),] }} 23 | $dump = $d.ddt: :get, C.new, color => False ; 24 | 25 | like $dump, /Role\{2\}/, 'second role' ; 26 | is $dump.lines.elems, 2, '2 lines dump' or diag $dump ; 27 | 28 | 29 | 30 | -------------------------------------------------------------------------------- /t/11_class_vs_role.t: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env perl6 2 | 3 | use Test ; 4 | plan 7 ; 5 | 6 | use Data::Dump::Tree ; 7 | use Data::Dump::Tree::DescribeBaseObjects ; 8 | 9 | my $d = Data::Dump::Tree.new does DDTR::AsciiGlyphs ; 10 | 11 | 12 | class UseDefault 13 | { 14 | has $.from_default = 'public' ; 15 | has $!from_default_private = 'private'; 16 | } 17 | 18 | my $dump = $d.ddt: :get, UseDefault.new, color => False ; 19 | like $dump, /from_default \s \=/, 'Shy first role' or diag $dump ; 20 | like $dump, /from_default_private/, 'Shy first role' or diag $dump ; 21 | is $dump.lines.elems, 3, '3 lines dump' ; 22 | 23 | class C 24 | { 25 | has $!a = 1 ; 26 | has $.b = 1 ; 27 | 28 | method ddt_get_elements { [ 'class', ' = ', $!a ], } 29 | } 30 | 31 | $dump = $d.ddt: :get, C.new ; 32 | 33 | like $dump, /class/, 'use class' ; 34 | is $dump.lines.elems, 2, '2 lines dump' ; 35 | 36 | 37 | role OverrideClassGetElements { multi method get_elements(C $c) {['role', ' = ', 'role' ],} } 38 | 39 | $d does OverrideClassGetElements ; 40 | $dump = $d.ddt: :get, C.new ; 41 | 42 | like $dump, /role/, 'use role' ; 43 | is $dump.lines.elems, 2, '2 lines dump' ; 44 | 45 | 46 | -------------------------------------------------------------------------------- /t/12_extra_standard_roles.t: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env perl6 2 | 3 | use Test; 4 | use Data::Dump::Tree ; 5 | use Data::Dump::Tree::ExtraRoles ; 6 | use Data::Dump::Tree::DescribeBaseObjects ; 7 | 8 | plan 9 ; 9 | 10 | my $d_1 = Data::Dump::Tree.new does DDTR::AsciiGlyphs ; 11 | 12 | my $dump_1 = $d_1.ddt: :get, :title<title>, :!color, "nl1\nnl2\nnl3" ; 13 | 14 | is $dump_1.lines.elems, 5, 'multi lines' or diag $dump_1 ; 15 | 16 | my $d_2 = Data::Dump::Tree.new does DDTR::PerlString ; 17 | $d_2 does DDTR::AsciiGlyphs ; 18 | 19 | my $dump_2 = $d_2.ddt: :get, :!color, "nl1\nnl1\nnl1" ; 20 | 21 | is $dump_2.lines.elems, 1, '1 lines' or diag $dump_2 ; 22 | 23 | my $d_3 = Data::Dump::Tree.new does DDTR::AsciiGlyphs ; 24 | my $dump_3 = $d_3.ddt: :get, :!color, sub{} ; 25 | 26 | like $dump_3, /anon/, 'default sub dump' ; 27 | is $dump_3.lines.elems, 1, 'default sub lines' or diag get_dump $dump_3; 28 | 29 | $dump_3 = $d_3.ddt: :get, :!color, sub{} ; 30 | 31 | unlike $dump_3, /sub \(\)/, 'silent sub dump' ; 32 | is $dump_3.lines.elems, 1, 'silent sub lines' ; 33 | 34 | grammar my_grammar { 35 | token TOP { 'fuu' \s+ <bar_t> \s+ <baz_t> \s <buu_t> }; 36 | token buu_t { <char_t>+ }; 37 | token bar_t { <char_t>+ }; 38 | token baz_t { <char_t>+ }; 39 | token char_t { \S }; 40 | }; 41 | 42 | my $d_4 = Data::Dump::Tree.new does DDTR::MatchDetails ; 43 | $d_4 does DDTR::AsciiGlyphs ; 44 | 45 | my $dump_4 = $d_4.ddt: :get, :!color, my_grammar.parse("fuu \n\nbart baz x") ; 46 | like($dump_4, /0\.\.15/, 'Grammar Match') ; 47 | is $dump_4.lines.elems, 15, 'Grammar Match lines' or diag get_dump $dump_4 ; 48 | 49 | my $dump_4_2 = $d_4.ddt: :get, :!color, 'ababa' ~~ m:g/a(b)/, display_perl_address => True ; 50 | is $dump_4_2.lines.elems, 5, 'terminal Match lines' or diag get_dump $dump_4_2; 51 | 52 | 53 | -------------------------------------------------------------------------------- /t/13_named_captures.t: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env perl6 2 | 3 | use Test ; 4 | plan 2 ; 5 | 6 | use Data::Dump::Tree ; 7 | use Data::Dump::Tree::ExtraRoles ; 8 | use Data::Dump::Tree::DescribeBaseObjects ; 9 | 10 | my regex header { \s* '[' \w+ ']' \h* \n+ } 11 | my regex identifier { \w+ } 12 | my regex kvpair { \s* <key=identifier> '=' <value=identifier> \n+ } 13 | my regex section { 14 | <header> 15 | <kvpair>* 16 | } 17 | 18 | my $contents = q:to/EOI/; 19 | [passwords] 20 | jack=password1 21 | joy=muchmoresecure123 22 | [quotas] 23 | jack=123 24 | joy=42 25 | EOI 26 | 27 | my $m = $contents ~~ /<section>*/ ; 28 | 29 | my $d = Data::Dump::Tree.new: :does[DDTR::MatchDetails, DDTR::PerlString, DDTR::AsciiGlyphs] ; 30 | 31 | my $dump_5 = $d.ddt: :get, $m, :title<roles via new>, :width(115), :!color ; 32 | is($dump_5.lines.elems, 28, '28 lines of section parsing, roles via new() ') or diag $dump_5 ; 33 | 34 | # ------------------------------- 35 | 36 | $m = $contents ~~ /<section>*/ ; 37 | 38 | my $d2 = Data::Dump::Tree.new does DDTR::AsciiGlyphs ; 39 | 40 | my $dump_6 = $d2.ddt: :get, $m, :title<roles via config>, :width(115), :does[DDTR::MatchDetails, DDTR::PerlString] ; 41 | 42 | is($dump_6.lines.elems, 28, '28 lines of section parsing, roles via config') or diag $dump_6 ; 43 | 44 | -------------------------------------------------------------------------------- /t/14.Match_limit.t: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env perl6 2 | 3 | use Test ; 4 | plan 13 ; 5 | 6 | use Data::Dump::Tree ; 7 | use Data::Dump::Tree::ExtraRoles ; 8 | use Data::Dump::Tree::DescribeBaseObjects ; 9 | 10 | my $d = Data::Dump::Tree.new does DDTR::AsciiGlyphs ; 11 | 12 | my $string = "aaaaa\n" x 4 ; 13 | my $dump ; 14 | 15 | $dump = $d.ddt: :get, $string ~~ /.*/, title => 'title', :!color ; 16 | is($dump.lines.elems, 6, '6 lines') or diag $dump ; 17 | 18 | $d does DDTR::PerlString ; 19 | $dump = $d.ddt: :get, $string ~~ /.*/, :!color ; 20 | is($dump.lines.elems, 1, '1 line') or diag $dump ; 21 | unlike $dump, /\+/, '' ; 22 | 23 | $d does DDTR::MatchStringLimit ; 24 | $dump = $d.ddt: :get, $string ~~ /.*/, :!color ; 25 | is($dump.lines.elems, 1, '1 line') or diag $dump ; 26 | like $dump, /\+14/, '' ; 27 | 28 | $d does DDTR::MatchStringLimit(12) ; 29 | $dump = $d.ddt: :get, $string ~~ /.*/, :!color ; 30 | is($dump.lines.elems, 1, '1 line') or diag $dump ; 31 | like $dump, /\+12/, '' ; 32 | 33 | $d.match_string_limit = 15 ; 34 | $dump = $d.ddt: :get, $string ~~ /.*/, :!color ; 35 | is($dump.lines.elems, 1, '1 line') or diag $dump ; 36 | like $dump, /\+9/, '' ; 37 | 38 | $d does DDTR::MatchDetails(3) ; 39 | $dump = $d.ddt: :get, $string ~~ /(.*)/, :!color ; 40 | is($dump.lines.elems, 2, '2 lines') or diag $dump ; 41 | like $dump, /\+21/, '' or diag $dump ; 42 | 43 | $d.match_string_limit = 15 ; 44 | $dump = $d.ddt: :get, $string ~~ /(.*)/, :!color ; 45 | is($dump.lines.elems, 2, '2 lines') or diag $dump ; 46 | like $dump, /\+9/, '' ; 47 | 48 | -------------------------------------------------------------------------------- /t/20_nothing.t: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env perl6 2 | 3 | use Test ; 4 | use Data::Dump::Tree ; 5 | use Data::Dump::Tree::DescribeBaseObjects ; 6 | 7 | plan 3 ; 8 | 9 | class HasNothing 10 | { 11 | 12 | #method ddt_get_header { ('', '.' ~ self.^name) } # use default 13 | method ddt_get_elements 14 | { 15 | [ 16 | ('nothing', '', Data::Dump::Tree::Type::Nothing), 17 | ('text', ' ', 'text'), 18 | ] 19 | } 20 | 21 | #class 22 | } 23 | 24 | my $d = Data::Dump::Tree.new(:!color, does => (DDTR::AsciiGlyphs,)) ; 25 | my $dump = $d.ddt: :get, HasNothing.new() ; 26 | 27 | is $dump.lines.elems, 3, '3 lines output' ; 28 | like $dump, /nothing/, 'nothing as no value' ; 29 | like $dump, /\.Str/, 'something has value' ; 30 | 31 | 32 | -------------------------------------------------------------------------------- /t/21_terminal.t: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env perl6 2 | 3 | use Test ; 4 | plan 4 ; 5 | 6 | use Data::Dump::Tree ; 7 | use Data::Dump::Tree::Enums ; 8 | use Data::Dump::Tree::DescribeBaseObjects ; 9 | 10 | my $d = Data::Dump::Tree.new does DDTR::AsciiGlyphs ; 11 | 12 | class C { has Any $!class_variable } 13 | 14 | my $dump = $d.ddt: :get, C.new, :!color ; 15 | 16 | like $dump, /class_variable/, 'default dump' ; 17 | is $dump.lines.elems, 2, '2 lines dump' ; 18 | 19 | 20 | $d does role { multi method get_header (C $l) { ('value_final', '.type_final', DDT_FINAL) } } 21 | 22 | $dump = $d.ddt: :get, C.new, :!color ; 23 | 24 | like $dump, /value_final\.type_final/, 'DDT_FINAL' ; 25 | is $dump.lines.elems, 1, '1 line dump' ; 26 | 27 | -------------------------------------------------------------------------------- /t/31_default_base_class.t: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env perl6 2 | 3 | use Test ; 4 | plan 2 ; 5 | 6 | use Data::Dump::Tree ; 7 | use Data::Dump::Tree::Enums ; 8 | 9 | class Hermit {} 10 | class LivesUnderRock {} 11 | class Shy is Hermit is LivesUnderRock { has $.in_object } 12 | 13 | my $dump = ddt :get, Hermit.new , color => False, display_address => DDT_DISPLAY_NONE ; 14 | like $dump, /\.Hermit/, '1 class' ; 15 | 16 | $dump = ddt :get, Shy.new , color => False, display_address => DDT_DISPLAY_NONE ; 17 | like $dump, /\.Shy \s \.Hermit \s \.LivesUnderRock/, '3 classes' ; 18 | 19 | -------------------------------------------------------------------------------- /t/32.exception.t: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env perl6 2 | 3 | use Test; 4 | plan 2 ; 5 | 6 | use Data::Dump::Tree; 7 | use Data::Dump::Tree::DescribeBaseObjects ; 8 | 9 | my $d = Data::Dump::Tree.new does DDTR::AsciiGlyphs ; 10 | 11 | my $dump = $d.ddt: :get, X::AdHoc.new(payload => 'text'), :!color ; 12 | 13 | like $dump, /X\:\:AdHoc/, 'exception' ; 14 | is $dump.lines.elems, 4, 'exception lines' or diag $dump; 15 | 16 | 17 | -------------------------------------------------------------------------------- /t/40_type_Map.t: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env perl6 2 | 3 | use Test ; 4 | plan 4 ; 5 | 6 | use Data::Dump::Tree ; 7 | 8 | my $d = Data::Dump::Tree.new ; 9 | 10 | my $dump = $d.ddt: :get, Map.new('a', 1, 'b', 2), :!color, :width(75) ; 11 | 12 | is $dump.lines.elems, 3, '3 lines of dump for Map' or diag $dump ; 13 | 14 | $dump = $d.ddt: :get, Map.new('a', (a => True), 'b', (b => False)), :!color, :width(75) ; 15 | 16 | is $dump.lines.elems, 3, '3 lines of dump for Map with pair keys' or diag $dump ; 17 | 18 | $dump = $d.ddt: :get, Map.new((key => True), (value => True), (key => (innerkey => True)), (value => (innervalue => True))), :!color, :width(75) ; 19 | is $dump.lines.elems, 3, '3 lines of dump for Map with pair keys' or diag $dump ; 20 | 21 | $dump = $d.ddt: :get, Map.new((key => (innerkey => True)), (value => (innervalue => True)), (key => (innerkey => (innerinnerkey => True))), (value => (innervalue => (innerinnervalue => True)))), :!color, :width(75) ; 22 | is $dump.lines.elems, 7, '7 lines of dump for Map with pairs with pairs as value' or diag $dump ; 23 | -------------------------------------------------------------------------------- /t/41_type_callframe.t: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env perl6 2 | 3 | use Test ; 4 | plan 4 ; 5 | 6 | use Data::Dump::Tree ; 7 | use Data::Dump::Tree::Enums ; 8 | 9 | my $d = Data::Dump::Tree.new ; 10 | 11 | multi sub Stash_no_sub($dumper, Stash $s, ($depth, $glyph, @renderings, $), @sub_elements) 12 | { 13 | # remove subs from stash 14 | @sub_elements = @sub_elements.grep: { $_[2] !~~ Sub} ; 15 | } 16 | 17 | multi sub compress_ddt($dumper, \r, Data::Dump::Tree $s, @r, (\k, \b, \v, \f, \final, \want_address)) 18 | { 19 | final = DDT_FINAL ; 20 | } 21 | 22 | my $dump = $d.ddt: :get, [callframe()], :!color, :width(75), :elements_filters[&Stash_no_sub], :header_filters[&compress_ddt] ; 23 | 24 | # Earlier rakudo versions had 35 lines, newer rakudo versions have 36 lines 25 | # because a new entry has come into the stash we're looking at here. 26 | is($dump.lines.elems, (35 | 36), 'lines of filtered callframedump') or diag $dump ; 27 | 28 | like $dump, /CallFrame/, 'CallFrame' or diag $dump ; 29 | like $dump, /'$.my'/, '$.my element' or diag $dump ; 30 | like $dump, /'Data::Dump::Tree'/, 'Data::Dump::Tree element' or diag $dump ; 31 | 32 | -------------------------------------------------------------------------------- /t/42_type_Map.t: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env perl6 2 | 3 | use Test ; 4 | plan 8 ; 5 | 6 | use Data::Dump::Tree ; 7 | use Data::Dump::Tree::ExtraRoles ; 8 | use Data::Dump::Tree::DescribeBaseObjects ; 9 | 10 | my $d = Data::Dump::Tree.new(width => 79, display_perl_address => False) does DDTR::MatchDetails ; 11 | 12 | my $string = 'aaaaaaaa' ; 13 | my regex xxx { $<t1> = aa $<t2> = a a } ; 14 | my regex yyy { ($<t1> = [aa] ) ($<t2> = a) a } ; 15 | 16 | my $dump_1 = $d.ddt: :get, color => False, title => "$string ~~ " ~ 'xxx', $string ~~ m:g/<xxx>/ ; 17 | is($dump_1.lines.elems, 9, '9 dump lines') or diag $dump_1 ; 18 | 19 | my $dump_2 = $d.ddt: :get, color => False, title => "$string ~~ " ~ 'yyy', $string ~~ m:g/<yyy>/ ; 20 | is($dump_2.lines.elems, 13, '13 dump lines, with capture') or diag $dump_2 ; 21 | like $dump_2, /"<0> aa"/, 'capture' or diag $dump_2 ; 22 | 23 | my $dump_3 = $d.ddt: :get, color => False, 'abc-abc-abc' ~~ / $<string>=( [ $<part>=[abc] ]* % '-' ) / ; 24 | is($dump_3.lines.elems, 5, '5 lines: title, top match, 3 sub macthes') or diag $dump_3 ; 25 | like $dump_3, /"<string> abc-abc-abc"/, 'top match' or diag $dump_3 ; 26 | 27 | my regex line { \N*\n } 28 | my $dump_4 = $d.ddt: :get, color => False, "abc\ndef\nghi" ~~ /<line>* ghi/, does => (DDTR::PerlString,) ; 29 | is($dump_4.lines.elems, 3, '3 Match lines') or diag $dump_4 ; 30 | 31 | my $dump_5 = $d.ddt: :get, color => False, regex { \s* '[' (\w+) ']' \h* \n+ } ; 32 | is($dump_5.lines.elems, 1, '1 line regex dump') or diag $dump_5 ; 33 | like $dump_5, /'\s* \'[\' (\w+) \']\' \h* \n+'/, 'regex rendering' or diag $dump_5 ; 34 | 35 | 36 | -------------------------------------------------------------------------------- /t/43_sequences.t: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env perl6 2 | 3 | use Test ; 4 | plan 20 ; 5 | 6 | use Data::Dump::Tree ; 7 | use Data::Dump::Tree::ExtraRoles ; 8 | 9 | my $d = Data::Dump::Tree.new: :!color ; 10 | 11 | my $dump = $d.ddt: :get, Seq(1, 2, 'x') ; 12 | is $dump.lines.elems, 4, '4 line' or diag $dump ; 13 | like $dump, /'.Seq'/, 'class name' or diag $dump ; 14 | 15 | $dump = $d.ddt: :get, (1...*) ; 16 | is $dump.lines.elems, 1, '1 line' or diag $dump ; 17 | like $dump, /'.Seq(*)'/, 'class name' or diag $dump ; 18 | 19 | $dump = $d.ddt: :get, (1...10_000) ; 20 | is $dump.lines.elems, 12, '12 line' or diag $dump ; 21 | like $dump, /'.Seq'/, 'class name' or diag $dump ; 22 | 23 | $dump = $d.ddt: :get, (1...3) ; 24 | is $dump.lines.elems, 4, '4 line' or diag $dump ; 25 | like $dump, /'.Seq'/, 'class name' or diag $dump ; 26 | 27 | $d.consume_seq<consume_lazy> = True ; 28 | $dump = $d.ddt: :get, (1...*) ; 29 | is $dump.lines.elems, 12, '12 line' or diag $dump ; 30 | like $dump, /'.Seq(*)'/, 'class name' or diag $dump ; 31 | 32 | $d.consume_seq<vertical> = False ; 33 | $dump = $d.ddt: :get, (1...*), :width(80) ; 34 | is $dump.lines.elems, 6, '6 line' or diag $dump ; 35 | like $dump, /'.Seq(*)'/, 'class name' or diag $dump ; 36 | 37 | $d.consume_seq<vertical> = False ; 38 | $dump = $d.ddt: :get, (1...3), :width(80) ; 39 | is $dump.lines.elems, 1, '1 line' or diag $dump ; 40 | like $dump, /'(1, 2, 3).Seq'/, 'dump and class name' or diag $dump ; 41 | 42 | $d.consume_seq<vertical> = False ; 43 | $dump = $d.ddt: :get, (1...50), :width(80) ; 44 | is $dump.lines.elems, 4, '4 line' or diag $dump ; 45 | like $dump, /'.Seq'/, 'class name' or diag $dump ; 46 | 47 | $d.consume_seq<vertical> = False ; 48 | $dump = $d.ddt: :get, (1...120), :width(80) ; 49 | is $dump.lines.elems, 6, '6 line' or diag $dump ; 50 | like $dump, /'.Seq'/, 'class name' or diag $dump ; 51 | like $dump, /'100'/, '100 elements' or diag $dump ; 52 | unlike $dump, /'101'/, 'limited to 100 elements' or diag $dump ; 53 | 54 | 55 | -------------------------------------------------------------------------------- /t/44.pair.t: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env perl6 2 | 3 | use Test ; 4 | plan 17 ; 5 | 6 | use Data::Dump::Tree ; 7 | 8 | my $d = Data::Dump::Tree.new ; 9 | 10 | my $dump = $d.ddt: :get, 1 => 'a', :!color ; 11 | 12 | like $dump.lines[0], /'(1, a).Pair'/, 'class name' or diag $dump ; 13 | is($dump.lines.elems, 1, '1 dump lines') or diag $dump ; 14 | 15 | 16 | $dump = $d.ddt: :get, (a => (< a >,)), :!color ; 17 | like $dump.lines[0], /^'.Pair'/, 'class name' or diag $dump ; 18 | is($dump.lines.elems, 4, '4 dump lines') or diag $dump ; 19 | 20 | 21 | for (Array, List) -> \typ { 22 | subtest typ.gist, { 23 | $dump = $d.ddt: :get, typ.new((a => (a => 1))), :!color ; 24 | like $dump.lines[1], /' .Pair'/, 'class name' or diag $dump ; 25 | is($dump.lines.elems, 4, '4 dump lines') or diag $dump ; 26 | } 27 | } 28 | 29 | $dump = $d.ddt: :get, Array.new((a => (a => 1))).Seq, :!color ; 30 | like $dump.lines[1], /'.Pair'/, 'class name' or diag $dump ; 31 | is($dump.lines.elems, 4, '4 dump lines') or diag $dump ; 32 | 33 | for (Hash, Map, Stash) -> \typ { 34 | subtest typ.gist, { 35 | $dump = $d.ddt: :get, typ.new("a", (a => 1)), :!color ; 36 | like $dump.lines[1], /'.Pair'/, 'class name' or diag $dump ; 37 | is($dump.lines.elems, 2, '2 dump lines') or diag $dump ; 38 | } 39 | subtest typ.gist ~ ".Seq", { 40 | $dump = $d.ddt: :get, typ.new("a", (a => 1)).Seq, :!color ; 41 | like $dump.lines[1], /' .Pair'/, 'class name' or diag $dump ; 42 | is($dump.lines.elems, 4, '4 dump lines') or diag $dump ; 43 | } 44 | } 45 | 46 | $dump = $d.ddt: :get, [a => (a => 1)], :!color ; 47 | like $dump.lines[1], /' .Pair'/, 'class name' or diag $dump ; 48 | is($dump.lines.elems, 4, '4 dump lines') or diag $dump ; 49 | 50 | my Any %silly_stuff{Any}; 51 | 52 | %silly_stuff{((innerkey => True) => "key's_value")} = (innervalue => True) => "values_value"; 53 | %silly_stuff{((innerkey => (innerinnerkey => True)) => "deep_keys_value")} = (innervalue => (innerinnervalue => True)) => "deep_values_value"; 54 | 55 | $dump = $d.ddt: :get, %silly_stuff, :!color, :width(75) ; 56 | is $dump.lines.elems, 10, '10 lines of dump for Object Hash with nested pairs as keys and pairs as values' or diag $dump ; 57 | -------------------------------------------------------------------------------- /t/45_junctions.t: -------------------------------------------------------------------------------- 1 | 2 | #!/usr/bin/env perl6 3 | 4 | use Test ; 5 | plan 6 ; 6 | 7 | use Data::Dump::Tree ; 8 | my $d = Data::Dump::Tree.new: :!color ; 9 | 10 | my $j = 1 | 'a' & True ; 11 | class C { has $.j } ; 12 | 13 | my $dump = $d.ddt: :get,C.new(:$j) ; 14 | is $dump.lines.elems, 2, '2 line' or diag $dump ; 15 | like $dump, /'.Junction'/, 'class name' or diag $dump ; 16 | 17 | 18 | $dump = $d.ddt: :get,$j ; 19 | is $dump.lines.elems, 1, '1 line' or diag $dump ; 20 | like $dump, /'.Junction'/, 'class name' or diag $dump ; 21 | 22 | 23 | $dump = $d.ddt: :get,[ ($j) ] ; 24 | is $dump.lines.elems, 2, '2 line' or diag $dump ; 25 | like $dump, /'.Junction'/, 'class name' or diag $dump ; 26 | 27 | -------------------------------------------------------------------------------- /t/46_Bool.t: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env perl6 2 | 3 | use Test ; 4 | plan 2 ; 5 | 6 | use Data::Dump::Tree ; 7 | 8 | my $d = Data::Dump::Tree.new ; 9 | 10 | my $dump = $d.ddt: :get, True, :!color ; 11 | is $dump.lines.elems, 1, '1 line' or diag $dump ; 12 | like $dump, /^'True'$$/, 'no class name' or diag $dump ; 13 | -------------------------------------------------------------------------------- /t/47_type_Set.t: -------------------------------------------------------------------------------- 1 | 2 | #!/usr/bin/env perl6 3 | 4 | use Test ; 5 | plan 1 ; 6 | 7 | use Data::Dump::Tree ; 8 | use Data::Dump::Tree::ExtraRoles ; 9 | use Data::Dump::Tree::DescribeBaseObjects ; 10 | 11 | my $d = Data::Dump::Tree.new: :!color, :width(79), :!display_perl_address ; 12 | my $s = set "zero" => 0, "one" => 1, "two" => 2 , "two" => 2, 7 ; 13 | 14 | my $r = $d.ddt: :get, :title<Set>, $s ; 15 | is($r.lines.elems, 5, '5 dump lines') or diag $r and diag $s.perl ; 16 | 17 | -------------------------------------------------------------------------------- /t/48_type_NativeCall.t: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env perl6 2 | 3 | use Test ; 4 | plan 17 ; 5 | 6 | use NativeCall ; 7 | use Data::Dump::Tree ; 8 | use Data::Dump::Tree::Enums ; 9 | use Data::Dump::Tree::ExtraRoles ; 10 | use Data::Dump::Tree::DescribeBaseObjects ; 11 | 12 | my $d = Data::Dump::Tree.new: :!color ; 13 | 14 | 15 | class Point is repr('CStruct') { 16 | has num64 $.x is rw; 17 | has num32 $.y; 18 | has int32 $.z = 3; 19 | } 20 | 21 | my $point = Point.new: :x(2e56), :y(10e10) ; 22 | 23 | my $dump = $d.ddt: :get, $point; 24 | is $dump.lines.elems, 4, '4 lines' or diag $dump ; 25 | like $dump, /'<CStruct>'/, '<CStruct>' or diag $dump ; 26 | like $dump, /'int32'/, 'int32' or diag $dump ; 27 | 28 | class Parts is repr('CUnion') { 29 | has int32 $.xyz; 30 | has int64 $.abc; 31 | } 32 | 33 | my Parts $union = Parts.new: :abc(10 ** 10) ; 34 | 35 | $dump = $d.ddt: :get, $union ; 36 | is $dump.lines.elems, 3, '3 lines' or diag $dump ; 37 | like $dump, /'<CUnion>'/, '<CUnion>' or diag $dump ; 38 | 39 | class MyStruct is repr('CStruct') { 40 | has Point $.point; # referenced 41 | submethod TWEAK() { $!point := Point.new }; 42 | } 43 | 44 | my $mystruct = MyStruct.new ; 45 | $mystruct.point.x = (my num64 $ = 888e0) ; 46 | 47 | $dump = $d.ddt: :get, $mystruct ; 48 | is $dump.lines.elems, 5, '5 lines' or diag $dump ; 49 | like $dump, /'int32'/, 'sub element' or diag $dump ; 50 | 51 | sub some_argless_function() is native('something') { * } 52 | 53 | $dump = $d.ddt: :get, &some_argless_function ; 54 | is $dump.lines.elems, 1, '1 line' or diag $dump ; 55 | like $dump, /'<NativeCall>'/, 'sub <NativeCall>' or diag $dump ; 56 | 57 | class MyHandle is repr('CPointer') {} 58 | $dump = $d.ddt: :get, MyHandle ; 59 | is $dump.lines.elems, 1, '1 line' or diag $dump ; 60 | like $dump, /'<CPointer>'/, '<CPointer>' or diag $dump ; 61 | 62 | my Pointer[int32] $pointer ; 63 | 64 | $dump = $d.ddt: :get, $pointer; 65 | is $dump.lines.elems, 1, '1 line' or diag $dump ; 66 | like $dump, /'<CPointer>'/, '<CPointer>' or diag $dump ; 67 | 68 | my int32 @int32 = 6, 7, 8 ; 69 | $dump = $d.ddt: :get, @int32; 70 | is $dump.lines.elems, 4, '4 lines' or diag $dump ; 71 | like $dump, /'<array>'/, '<array>' or diag $dump ; 72 | 73 | my $carray_titles = CArray[Str].new; 74 | $carray_titles[0] = 'Me'; 75 | $carray_titles[1] = 'You'; 76 | 77 | $dump = $d.ddt: :get, $carray_titles ; 78 | is $dump.lines.elems, 3, '3 lines' or diag $dump ; 79 | like $dump, /'<CArray>'/, 'CArray>' or diag $dump ; 80 | 81 | -------------------------------------------------------------------------------- /t/49_Buf.t: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env perl6 2 | 3 | use Data::Dump::Tree ; 4 | 5 | use Test ; 6 | plan 6 ; 7 | 8 | my $r = ddt :get, :!color, Buf ; 9 | is $r.lines.elems, 1, '1 line' or diag $r ; 10 | like $r, /'.Buf:U'/, 'Buf' or diag $r ; 11 | 12 | $r = ddt :get, :!color, Buf.new(1, 2, 3) ; 13 | is $r.lines.elems, 4, '4 lines' or diag $r ; 14 | like $r, /'.Buf[3] <array>'/, 'Buf.new' or diag $r ; 15 | 16 | $r = ddt :get, :!color, "ddt_remote".encode('utf-8') ; 17 | is $r.lines.elems, 11, '11 lines' or diag $r ; 18 | like $r, /'.utf8[10] <array>'/, 'utf8' or diag $r ; 19 | 20 | 21 | -------------------------------------------------------------------------------- /t/50_Bag.t: -------------------------------------------------------------------------------- 1 | 2 | #!/usr/bin/env perl6 3 | 4 | use Test ; 5 | plan 12 ; 6 | 7 | use Data::Dump::Tree ; 8 | 9 | my $d = Data::Dump::Tree.new: :!color, :width(79), :!display_perl_address ; 10 | 11 | my $r = $d.ddt: :get, :title<Bag>, <a b c a>.Bag ; 12 | is($r.lines.elems, 4, '4 dump lines') or diag $r ; 13 | like $r, /'Bag(3)'/, '3 elements' or diag $r ; 14 | like $r, /'a => 2'/, "2 'a's" or diag $r ; 15 | like $r, /'c => 1'/, "1 'c'" or diag $r ; 16 | 17 | $r = $d.ddt: :get, :title<Bag>, Bag ; 18 | is($r.lines.elems, 1, '1 dump lines') or diag $r ; 19 | like $r, /\.Bag\:U/, 'undefined Bag' or diag $r ; 20 | 21 | 22 | $r = $d.ddt: :get, :title<BagHash>, BagHash.new: <a b c a> ; 23 | is($r.lines.elems, 4, '4 dump lines') or diag $r ; 24 | like $r, /'BagHash(3)'/, '3 elements' or diag $r ; 25 | like $r, /'a => 2'/, "2 'a's" or diag $r ; 26 | like $r, /'c => 1'/, "1 'c'" or diag $r ; 27 | 28 | $r = $d.ddt: :get, :title<BagHash>, BagHash ; 29 | is($r.lines.elems, 1, '1 dump lines') or diag $r ; 30 | like $r, /\.BagHash\:U/, 'undefined BagHash' or diag $r ; 31 | 32 | 33 | -------------------------------------------------------------------------------- /t/51_Slip.t: -------------------------------------------------------------------------------- 1 | use Test ; 2 | plan 8 ; 3 | 4 | use Data::Dump::Tree ; 5 | 6 | my $d = Data::Dump::Tree.new: :!color, :width(79), :!display_perl_address ; 7 | 8 | my $r = $d.ddt: :get, :title<Slip>, Slip ; 9 | is($r.lines.elems, 1, '1 dump line') or diag $r ; 10 | like $r, /'.Slip:U'/, 'undefined Slip' or diag $r ; 11 | 12 | $r = $d.ddt: :get, :title<Slip>, ().Slip ; 13 | is($r.lines.elems, 1, '1 dump line') or diag $r ; 14 | like $r, /'(0).Slip'/, 'empty Slip' or diag $r ; 15 | 16 | $r = $d.ddt: :get, :title<Slip>, (1,2,3).Slip ; 17 | is($r.lines.elems, 4, '4 dump lines') or diag $r ; 18 | like $r, /'(3).Slip'/, '3 elements' or diag $r ; 19 | like $r, /'0 = 1'/, "first line" or diag $r ; 20 | like $r, /'2 = 3'/, "last line" or diag $r ; 21 | 22 | 23 | -------------------------------------------------------------------------------- /t/70_sub_interface.t: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env perl6 2 | 3 | use Test ; 4 | use Data::Dump::Tree ; 5 | 6 | plan 1 ; 7 | 8 | class C { has $.in_object = 'in_object' } 9 | like (ddt :get, C.new, color => False), /in_object/, 'access via sub' ; 10 | 11 | -------------------------------------------------------------------------------- /t/71_filter.t: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env perl6 2 | 3 | use Test ; 4 | use Data::Dump::Tree ; 5 | use Data::Dump::Tree::DescribeBaseObjects ; 6 | 7 | plan 4 ; 8 | 9 | # this is a small example of a filter. I was curious about how DDT would 10 | # render itself. After a few try runs, with different options, I got tired of 11 | # seeing a long list which consists of a lot of colors so I decided to filter 12 | # them out 13 | 14 | 15 | # remove the Hashes 16 | multi sub header_filter($dumper, \r, Hash $s, ($depth, $path, $glyph, @renderings), (\k, \b, \v, \f, \final, \want_address)) 17 | { 18 | # but only the one the ones which names contain the word 'color' 19 | # DDT calls the type handler before the filters so it has already all 20 | # kind of information that we can use in our filter 21 | 22 | if k ~~ /color/ 23 | { 24 | @renderings.push: (|$glyph, ('', 'removing ' ~ k, '')) ; 25 | r = Data::Dump::Tree::Type::Nothing ; 26 | } 27 | else 28 | { 29 | @renderings.push: (|$glyph, ('', 'not removing ' ~ k, '')) ; 30 | } 31 | } 32 | 33 | 34 | # we can also act at a higher level, this filter catches the DDT object 35 | # before the Hashes are displayed 36 | multi sub elements_filter($dumper, Data::Dump::Tree $s, ($depth, $glyph, @renderings, $), @sub_elements) 37 | { 38 | # simply show that we were called 39 | @renderings.push: (|$glyph, ('', 'SUB ELEMENTS', '')) ; 40 | 41 | # we could have eliminated any sub element from @sub_elements, or even 42 | # added some elements 43 | } 44 | 45 | my $d = Data::Dump::Tree.new does DDTR::AsciiGlyphs ; 46 | my $dump = $d.ddt: :get, $d, :!color, :width<80>, :header_filters[&header_filter], :elements_filters[&elements_filter] ; 47 | 48 | is $dump.lines.elems, 56, 'lines output' or diag $dump ; 49 | like $dump, /removing/, 'removing' or diag $dump ; 50 | like $dump, /'not removing'/, 'not removing' or diag $dump ; 51 | like $dump, /'SUB ELEMENTS'/, 'sub elements filter' or diag $dump ; 52 | 53 | -------------------------------------------------------------------------------- /t/80_title.t: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env perl6 2 | 3 | use Test ; 4 | plan 14 ; 5 | 6 | use Data::Dump::Tree ; 7 | 8 | my $dump = ddt :get,1, :!color ; 9 | unlike $dump, /one/, 'title' ; 10 | unlike $dump, /\@/, 'address' ; 11 | 12 | $dump = ddt :get,1, :!color ; 13 | unlike $dump, /one/, 'title' ; 14 | unlike $dump, /\@/, 'address' ; 15 | 16 | $dump = ddt :get,1, :!color, caller => True ; 17 | unlike $dump, /one/, 'title' ; 18 | like $dump, /\@/, 'address' ; 19 | 20 | $dump = ddt :get,1, :!color, caller => False ; 21 | unlike $dump, /one/, 'title' ; 22 | unlike $dump, /\@/, 'address' ; 23 | 24 | $dump = ddt :get,1, :!color, title => 'one' ; 25 | like $dump, /one/, 'title' ; 26 | unlike $dump, /\@/, 'address' ; 27 | 28 | $dump = ddt :get,1, :!color, title => 'one', caller => True ; 29 | like $dump, /one/, 'title' ; 30 | like $dump, /\@/, 'address' ; 31 | 32 | $dump = get_dump(1, :!color, title => 'one', caller => False) ; 33 | like $dump, /one/, 'title' ; 34 | unlike $dump, /\@/, 'address' ; 35 | 36 | -------------------------------------------------------------------------------- /t/81_color.t: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env perl6 2 | 3 | use Test; 4 | use Data::Dump::Tree; 5 | use Data::Dump::Tree::MultiColumns ; 6 | 7 | use Test ; 8 | plan 21 ; 9 | 10 | # render in BW and color and compare the lines generated 11 | 12 | my @a = [4..5] ; 13 | my $d = [[[[1..2],[3..4],],]] ; 14 | my %h1 = <c 3> ; 15 | my %h2 = <a 1 b 2> ; 16 | my $s = ([1..3], %h1, %h2, @a) ; 17 | 18 | my %h3 = <a 1 b 2 c 3 d 4> ; 19 | my @a2 = [1..10] ; 20 | my $d2 = ([1..10], [|(1..10), @a2 ], %h3) ; 21 | 22 | my $d3 = ([1..10], [|(1..10), [|(1..22), %h1, %h2,%h2, |(23..30), [1..6], |(1..4)] ], {some => {a => 1, b => [|(1..5), %h1]}, thing => $s}) ; 23 | 24 | for 25 | ( 26 | (13, :title<test 10, string>, $s, :flat(10, <hello>)), 27 | (13, :title<test [1..3]>, $s, :flat([1..3],)), 28 | (12, :title<test Hash>, $s, :flat(Hash,)), 29 | (5, :title<test 0>, $s, :flat(0)), 30 | (10, :title<test 2>, ($d, [3..5]), :flat(2)), 31 | (12, :title<test 3>, ($d, [3..5], $d), :flat(3)), 32 | (13, :title<<test %(a => 1, b => 2)>>, $s, :flat(%(a => 1, b => 2),)), 33 | (13, :title<test %h1>, $s, :flat(%h1,)), 34 | (12, :title<test @a>, $s, :flat(@a,)), 35 | (12, :title<test sub: Hash>, $s, :flat({$_ ~~ Hash})), 36 | (11, :title<test sub Array $s.first: 3>, $s, :flat({$_ ~~ Array && $_.first: 3})), 37 | (13, :title<test sub: $s == %h1>, $s, :flat({$_ === %h1})), 38 | # columns 39 | (39, :title<flat()>, $d2, :flat()), 40 | (38, :title<flat((H, 2))>, $d2, :flat((Hash, 2),)), 41 | (23, :title<flat((sA, 2))>, $d2, :flat(({$_ ~~ Array && $*d == 1}, 2), )), 42 | (26, :title<flat((sA, L1, *5) 2)>, $d2, :flat(({$_ ~~ Array && $*d == 1, 5}, 2), )), 43 | (35, :title<flat((sA, L2, *5) 2)>, $d2, :flat(({$_ ~~ Array && $*d == 2, 5}, 2), )), 44 | (35, :title<flat((s@a2, L2, *5) 2)>, $d2, :flat(({$_ === @a2 && $*d == 2, 5}, 2), )), 45 | (35, :title<flat((sA, L2, *5) 2)>, $d2, :flat({$_ ~~ Array && $*d == 2, 5}, )), 46 | (22, :title<flat((sA, *5) 2)>, $d2, :flat(({$_ ~~ Array, 5}, 2), )), 47 | 48 | # hash flatten if more than two keys, if less only if keys are non final 49 | # array guess number of columns based on the number of elements and left space and rendering, which we know nothing about :) 50 | (47, :title<d3, flat(H, sA-5)>, $d3, :flat({$_ ~~ Hash && $_.keys > 1}, {$_ ~~ Array && $_.elems > 5, 5} )), 51 | ) 52 | { 53 | my ($lines, $title, $ds, $flat) = | $_ ; 54 | my Capture $c = \(|$title, $ds, |$flat) ; 55 | 56 | my $bw = ddt :get_lines_integrated, |$c, :width(80), :!color ; 57 | my $col = ddt :get_lines_integrated, |$c, :width(80) ; 58 | 59 | my regex ansi_color { \e \[ \d+ [\;\d+]* <?before [\;\d+]* > m } 60 | 61 | is($col.map({ S:g/ <ansi_color> // with $_}), $bw, 'same contents') or do 62 | { 63 | display_columns ('-' x 40, |$bw, '-' x 40), ('-' x 40, |$col, '-' x 40) ; 64 | } 65 | } 66 | 67 | 68 | 69 | -------------------------------------------------------------------------------- /t/82_max_depth.t: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env perl6 2 | 3 | use Test ; 4 | plan 2 ; 5 | 6 | use Data::Dump::Tree ; 7 | 8 | my $dump = ddt :get, [ [[[],],], [[],], [] ], max_depth => 3, color => False ; 9 | is $dump.lines.elems, 8, '8 dump lines' or diag $dump ; 10 | is +($dump ~~ m:g/(max \s depth)/) , 2, '2 over limit' ; 11 | 12 | -------------------------------------------------------------------------------- /t/83_width.t: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env perl6 2 | 3 | use Test ; 4 | plan 10 ; 5 | 6 | use Data::Dump::Tree; 7 | use Data::Dump::Tree::DescribeBaseObjects ; 8 | 9 | my $dump = ddt :get, '1234567890' x 6, title => 't:', width => 79, color => False, does => (DDTR::AsciiGlyphs,) ; 10 | is $dump.lines.elems, 1, '1 line, default width setting' or diag $dump ; 11 | 12 | $dump = ddt :get, '1234567890' x 8, title => 't:', color => False, width => 79, does => (DDTR::AsciiGlyphs,) ; 13 | is $dump.lines.elems, 4, '4 lines, default width setting' or diag $dump ; 14 | 15 | $dump = ddt :get, '1234567890' x 8, title => 't:', color => False, width => 20, does => (DDTR::AsciiGlyphs,) ; 16 | is $dump.lines.elems, 6, '6 lines, width set to 20' or diag $dump ; 17 | is all($dump.lines>>.chars) <= 20, True, 'all lines under 20 chars' or do { diag $dump.lines>>.chars ;diag $dump ; } 18 | 19 | $dump = ddt :get, ['1234567890' x 8], title => 't:', color => False, width => 22, does => (DDTR::AsciiGlyphs,) ; 20 | is $dump.lines.elems, 8, '8 lines, width set to 22' or diag $dump ; 21 | is all($dump.lines>>.chars) <= 22, True, 'all lines under 22 chars' or do { diag $dump.lines>>.chars ; diag $dump ; } 22 | 23 | $dump = ddt :get, '1234567890' x 5, title => '12345' x 5, color => False, width => 22, does => (DDTR::AsciiGlyphs,) ; 24 | is $dump.lines.elems, 6, '6 lines, width set to 20' or diag $dump ; 25 | is all($dump.lines>>.chars) <= 70, True, 'all lines under 70 chars' or do { diag $dump.lines>>.chars ;diag $dump ; } 26 | 27 | $dump = ddt :get, "12345678901234567890\n" x 3, title => '12345' x 5, color => False, width => 15, does => (DDTR::AsciiGlyphs,) ; 28 | is $dump.lines.elems, 9, '9 lines, width set to 15, embedded \n' or diag $dump ; 29 | is all($dump.lines>>.chars) <= 15, True, 'all lines under 15 chars' or do { diag $dump.lines>>.chars ;diag $dump ; } 30 | 31 | 32 | -------------------------------------------------------------------------------- /t/90_foldable.t: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env perl6 2 | 3 | use Data::Dump::Tree ; 4 | use Data::Dump::Tree::Foldable ; 5 | 6 | use Test ; 7 | plan 26 ; 8 | 9 | # DDT filter to show the folding internal data in a better way 10 | sub filter($dumper, \r, $s, ($, $path, @glyphs, @renderings), (\k, \b, \v, \f, \final, \want_address)) 11 | { 12 | r = Data::Dump::Tree::Type::Nothing if k ~~ /'$.foldable'/ ; 13 | 14 | if k ~~ /'@.folds'/ 15 | { 16 | try 17 | { 18 | require Text::Table::Simple <&lol2table> ; 19 | 20 | r = lol2table( 21 | < index skip folded parent >, 22 | ($s.List Z 0..*).map: -> ($d, $i) { [$i, |$d] }, 23 | ).join("\n") ; 24 | 25 | } 26 | 27 | @renderings.push: "$!" if $! ; 28 | } 29 | } 30 | 31 | my $f = Data::Dump::Tree::Foldable.new: (^20).List, :title<title>, :!color ; 32 | my $g = $f.get_view ; 33 | my @dump = $g.get_lines.map( { $_.map( {$_.join} ).join } ) ; 34 | is @dump.elems, 21, '21 lines' or diag @dump.join("\n") ; 35 | like @dump[0], /title/, 'top is title' or diag @dump.join("\n") ; 36 | 37 | 38 | $g.set: :top_line<1>, :page_size<10> ; 39 | @dump = $g.get_lines.map( { $_.map( {$_.join} ).join } ) ; 40 | is @dump.elems, 10, '10 lines' or diag @dump.join("\n") ; 41 | like @dump[0], /0/, 'top line changed' or diag @dump.join("\n") ; 42 | 43 | $g.set: :page_size<-10> ; 44 | @dump = $g.get_lines.map( { $_.map( {$_.join} ).join } ) ; 45 | is @dump.elems, 0, '0 lines' or diag @dump.join("\n") ; 46 | 47 | $g.set: :page_size<10> ; 48 | $g.line_down ; 49 | @dump = $g.get_lines.map( { $_.map( {$_.join} ).join } ) ; 50 | is @dump.elems, 10, '10 lines' or diag @dump.join("\n") ; 51 | like @dump[0], /1/, 'line down' or diag @dump.join("\n") ; 52 | 53 | $g.line_down for ^20; 54 | @dump = $g.get_lines.map( { $_.map( {$_.join} ).join } ) ; 55 | is @dump.elems, 1, '1 line' or diag @dump.join("\n") ; 56 | like @dump[0], /19/, 'last line' or diag @dump.join("\n") ; 57 | 58 | $g.page_down ; 59 | #diag get_dump $g, header_filters => (&filter,) ; 60 | @dump = $g.get_lines.map( { $_.map( {$_.join} ).join } ) ; 61 | like @dump[0], /19/, 'page down, last line' or diag @dump.join("\n") ; 62 | 63 | $g.page_up ; 64 | @dump = $g.get_lines.map( { $_.map( {$_.join} ).join } ) ; 65 | like @dump[0], /9/, 'page up' or diag @dump.join("\n") ; 66 | 67 | $g.page_up for ^15; 68 | @dump = $g.get_lines.map( { $_.map( {$_.join} ).join } ) ; 69 | like @dump[0], /title/, 'max page up' or diag @dump.join("\n") ; 70 | 71 | $g.line_up ; 72 | @dump = $g.get_lines.map( { $_.map( {$_.join} ).join } ) ; 73 | like @dump[0], /title/, 'max line up' or diag @dump.join("\n") ; 74 | 75 | 76 | class Tomatoe{ has $.color ;} 77 | my $s = 78 | [ 79 | Tomatoe, 80 | [ [ [ Tomatoe, ] ], ], 81 | 123, 82 | Tomatoe.new( color => 'green'), 83 | (^5).list, 84 | ] ; 85 | 86 | $f = Data::Dump::Tree::Foldable.new($s, :title<title>, :!color) ; 87 | $g = $f.get_view ; 88 | #diag get_dump ($f => $g) ; 89 | @dump = $g.get_lines.map( { $_.map( {$_.join} ).join } ) ; 90 | is @dump.elems, 15, '15 lines' or diag @dump.join("\n") ; 91 | 92 | $g.fold_flip_selected ; 93 | #diag get_dump $g, header_filters => (&filter,) ; 94 | @dump = $g.get_lines ; 95 | is @dump.elems, 1, '1 line fold' or diag @dump.join("\n") ; 96 | 97 | $g.fold_all ; 98 | @dump = $g.get_lines.map( { $_.map( {$_.join} ).join } ) ; 99 | is @dump.elems, 1, '1 line fold' or diag @dump.join("\n") ; 100 | 101 | $g.unfold_all ; 102 | @dump = $g.get_lines.map( { $_.map( {$_.join} ).join } ) ; 103 | is @dump.elems, 15, '15 lines' or diag @dump.join("\n") ; 104 | 105 | $g.set: :selected_line(3) ; 106 | $g.fold_flip_selected ; 107 | @dump = $g.get_lines.map( { $_.map( {$_.join} ).join } ) ; 108 | is @dump.elems, 13, '13 lines, 1 fold' or diag @dump.join("\n") ; 109 | 110 | $g.set: :selected_line(7) ; 111 | $g.fold_flip_selected ; 112 | @dump = $g.get_lines.map( { $_.map( {$_.join} ).join } ) ; 113 | is @dump.elems, 8, '8 lines, 2 folds' or diag @dump.join("\n") ; 114 | 115 | $g.line_down for ^3 ; 116 | @dump = $g.get_lines.map( { $_.map( {$_.join} ).join } ) ; 117 | is @dump.elems, 5, '5 lines, 2 folds' or diag @dump.join("\n") ; 118 | like @dump[0], /1/, 'at index 1' or diag @dump.join("\n") ; 119 | 120 | $g.line_down ; 121 | @dump = $g.get_lines.map( { $_.map( {$_.join} ).join } ) ; 122 | is @dump.elems, 4, '4 lines, 2 folds' or diag @dump.join("\n") ; 123 | like @dump[0], /2/, 'at index 2' or diag @dump.join("\n") ; 124 | 125 | $g.line_up ; 126 | @dump = $g.get_lines.map( { $_.map( {$_.join} ).join } ) ; 127 | is @dump.elems, 5, '5 lines, 2 folds' or diag @dump.join("\n") ; 128 | like @dump[0], /1/, 'at index 1' or diag @dump.join("\n") ; 129 | 130 | $g.line_up for ^3 ; 131 | @dump = $g.get_lines.map( { $_.map( {$_.join} ).join } ) ; 132 | is @dump.elems, 8, '8 lines, 2 folds' or diag @dump.join("\n") ; 133 | 134 | -------------------------------------------------------------------------------- /xt/02_META.t: -------------------------------------------------------------------------------- 1 | #!perl6 2 | 3 | use v6; 4 | use lib 'lib'; 5 | 6 | use Test; 7 | use Test::META; 8 | 9 | plan 1; 10 | 11 | # That's it 12 | meta-ok(); 13 | 14 | 15 | done-testing; 16 | 17 | --------------------------------------------------------------------------------