File Coverage

blib/lib/Tree/DAG_Node/Persist.pm
Criterion Covered Total %
statement 65 68 95.5
branch 11 12 91.6
condition 8 10 80.0
subroutine 9 9 100.0
pod 0 3 0.0
total 93 102 91.1


line stmt bran cond sub pod time code
1             package Tree::DAG_Node::Persist;
2              
3 1     1   795 use strict;
  1         1  
  1         24  
4 1     1   4 use warnings;
  1         1  
  1         18  
5              
6 1     1   3 use Moo;
  1         1  
  1         4  
7              
8 1     1   205 use Scalar::Util 'refaddr';
  1         1  
  1         41  
9              
10 1     1   9 use Tree::DAG_Node;
  1         1  
  1         23  
11              
12 1     1   2 use Types::Standard qw/Any Str/;
  1         1  
  1         5  
13              
14             has context =>
15             (
16             default => sub{return '-'},
17             is => 'rw',
18             isa => Str,
19             required => 0,
20             );
21              
22             has context_col =>
23             (
24             default => sub{return 'context'},
25             is => 'rw',
26             isa => Str,
27             required => 0,
28             );
29              
30             has dbh =>
31             (
32             default => sub{return ''},
33             is => 'rw',
34             isa => Any,
35             required => 0,
36             );
37              
38             has id_col =>
39             (
40             default => sub{return 'id'},
41             is => 'rw',
42             isa => Str,
43             required => 0,
44             );
45              
46             has mother_id_col =>
47             (
48             default => sub{return 'mother_id'},
49             is => 'rw',
50             isa => Str,
51             required => 0,
52             );
53              
54             has name_col =>
55             (
56             default => sub{return 'name'},
57             is => 'rw',
58             isa => Str,
59             required => 0,
60             );
61              
62             has table_name =>
63             (
64             default => sub{return 'trees'},
65             is => 'rw',
66             isa => Str,
67             required => 0,
68             );
69              
70             has unique_id_col =>
71             (
72             default => sub{return 'unique_id'},
73             is => 'rw',
74             isa => Str,
75             required => 0,
76             );
77              
78             our $VERSION = '1.11';
79              
80             # --------------------------------------------------
81              
82             sub read
83             {
84 2     2 0 1352 my($self, $extra) = @_;
85 2         69 my($table_name) = $self -> table_name;
86 2         68 my($sql) =
87             "select * from $table_name where " .
88             $self -> context_col .
89             ' = ? order by ' .
90             $self -> unique_id_col;
91 2         84 my($record) = $self -> dbh -> selectall_arrayref($sql, {Slice => {} }, $self -> context);
92              
93 2 100       1014 if (! $extra)
94             {
95 1         4 $extra = [];
96             }
97              
98 2         5 my($id);
99             my($mother_id);
100 0         0 my($node);
101 0         0 my($row, $root_id);
102 0         0 my(%seen);
103              
104 2         4 for $row (@$record)
105             {
106 41         2046 $id = $$row{$self -> id_col};
107 41         1314 $mother_id = $$row{$self -> mother_id_col};
108 41         178 $node = Tree::DAG_Node -> new();
109 41         807 $seen{$id} = $node;
110 41         35 ${$node -> attributes}{id} = $id;
  41         75  
111 41         183 ${$node -> attributes}{$_} = $$row{$_} for @$extra;
  20         26  
112              
113 41         656 $node -> name($$row{$self -> name_col});
114              
115 41 100       298 if ($seen{$mother_id})
    50          
116             {
117 39         71 $seen{$mother_id} -> add_daughter($node);
118             }
119             elsif (! $mother_id)
120             {
121 2         2 $root_id = $id;
122             }
123             }
124              
125 2         105 return $seen{$root_id};
126              
127             } # End of read.
128              
129             # --------------------------------------------------
130              
131             sub write_node
132             {
133 41     41 0 3692 my($node, $opt) = @_;
134              
135 41         95 $$opt{unique_id}++;
136              
137 41         251 my($mother) = $node -> mother;
138 41 100       478 my($mum_ref) = $mother ? refaddr $mother : 0;
139 41   100     303 my($mum_id) = $$opt{id}{$mum_ref} || 0;
140              
141             $$opt{sth} -> execute
142             (
143             $mum_id,
144             $$opt{unique_id},
145             $$opt{context},
146             $node -> name,
147 41         323 map{${$node -> attributes}{$_} } @{$$opt{extra} },
  20         23  
  20         105  
  41         1534138  
148             );
149              
150 41         2439015 my($id) = $$opt{dbh} -> last_insert_id(undef, undef, $$opt{table_name}, undef);
151 41         287 my($refaddr) = refaddr $node;
152 41         360 $$opt{id}{$refaddr} = $id;
153              
154 41         434 return 1;
155              
156             } # End of write_node.
157              
158             # --------------------------------------------------
159              
160             sub write
161             {
162 2     2 0 20417 my($self, $tree, $extra) = @_;
163 2         32 my($table_name) = $self -> table_name;
164 2         1469 my($sql) = "delete from $table_name where " . $self -> context_col . ' = ?';
165 2         782 my($sth) = $self -> dbh -> prepare_cached($sql);
166              
167 2         998 $sth -> execute($self -> context);
168              
169 2         1062 $sql = "insert into $table_name (" .
170             $self -> mother_id_col .
171             ', ' .
172             $self -> unique_id_col .
173             ', ' .
174             $self -> context_col .
175             ', ' .
176             $self -> name_col;
177              
178 2 100 66     2649 if ($extra && @$extra)
179             {
180 1         8 $sql .= ', ' . join(', ', @$extra);
181             }
182              
183 2         5 $sql .= ') values (?, ?, ?, ?';
184              
185 2 100 66     17 if ($extra && @$extra)
186             {
187 1         4 $sql .= ', ?' x @$extra;
188             }
189              
190 2         6 $sql .= ')';
191              
192 2   100     45 $tree -> walk_down
193             ({
194             callback => \&write_node,
195             context => $self -> context,
196             dbh => $self -> dbh,
197             _depth => 0,
198             extra => $extra || [],
199             id => {},
200             self => $self,
201             sth => $self -> dbh -> prepare_cached($sql),
202             table_name => $self -> table_name,
203             unique_id => 0,
204             });
205              
206             } # End of write.
207              
208             # -----------------------------------------------
209              
210             1;
211              
212             =pod
213              
214             =head1 NAME
215              
216             Tree::DAG_Node::Persist - Persist multiple trees in a single db table, preserving child order
217              
218             =head1 Synopsis
219              
220             my($master) = Tree::DAG_Node::Persist -> new
221             (
222             context => 'Master',
223             context_col => 'context',
224             dbh => $dbh,
225             id_col => 'id',
226             mother_id_col => 'mother_id',
227             name_col => 'name',
228             table_name => $table_name,
229             unique_id_col => 'unique_id',
230             );
231              
232             my($tree) = build_tree; # Somehow... See the FAQ for help.
233              
234             $master -> write($tree);
235              
236             my($shrub) = $master -> read;
237              
238             # Prune $shrub by adding/deleting its nodes...
239              
240             my($offshoot) = Tree::DAG_Node::Persist -> new
241             (
242             context => 'Offshoot', # Don't use Master or it'll overwrite $tree in the db.
243             dbh => $dbh,
244             );
245              
246             $offshoot -> write($shrub);
247              
248             =head1 Description
249              
250             L reads/writes multiple trees from/to a single database table, where those
251             trees are built using L.
252              
253             See the L for details of the table structure.
254              
255             =head1 Distributions
256              
257             This module is available as a Unix-style distro (*.tgz).
258              
259             See L
260             for help on unpacking and installing distros.
261              
262             =head1 Installing the module
263              
264             Install L as you would for any C module:
265              
266             Run:
267              
268             cpanm Tree::DAG_Node::Persist
269              
270             or run:
271              
272             sudo cpan Tree::DAG_Node::Persist
273              
274             or unpack the distro, and then either:
275              
276             perl Build.PL
277             ./Build
278             ./Build test
279             sudo ./Build install
280              
281             or:
282              
283             perl Makefile.PL
284             make (or dmake)
285             make test
286             make install
287              
288             =head1 Method: context([$new_value])
289              
290             Get or set the value to be used in the 'context' column when the tree is written to or read from
291             the database.
292              
293             =head1 Method: context_col([$new_value])
294              
295             Get or set the value to be used as the name of the 'context' column when the tree is written to or
296             read from the database.
297              
298             =head1 Method: dbh([$new_value])
299              
300             Get or set the value to be used as the database handle when the tree is written to or read from the
301             database.
302              
303             =head1 Method: id_col([$new_value])
304              
305             Get or set the value to be used as the name of the 'id' column when the tree is written to or read
306             from the database.
307              
308             =head1 Method: mother_id_col([$new_value])
309              
310             Get or set the value to be used as the name of the 'mother_id' column when the tree is written to
311             or read from the database.
312              
313             =head1 Method: name_col([$new_value])
314              
315             Get or set the value to be used as the name of the 'name' column when the tree is written to or
316             read from the database.
317              
318             =head1 Method: new({...})
319              
320             Returns a new object of type C.
321              
322             Key-value pairs in the hashref:
323              
324             =over 4
325              
326             =item context => $a_string
327              
328             This is the value to be used in the 'context' column when the tree is written to or read from the
329             database.
330              
331             This key is optional.
332              
333             It defaults to '-'.
334              
335             =item context_col => $a_string
336              
337             This is the name to be used for the 'context' column when the tree is written to or read from the
338             database.
339              
340             This key is optional.
341              
342             If defaults to 'context'.
343              
344             =item dbh => A database handle
345              
346             This is the database handle to use.
347              
348             This key-value pair is mandatory.
349              
350             There is no default.
351              
352             =item id_col => $a_string
353              
354             This is the name to be used for the 'id' column when the tree is written to or read from the
355             database.
356              
357             This key is optional.
358              
359             If defaults to 'id'.
360              
361             =item mother_id_col => $a_string
362              
363             This is the name to be used for the 'mother_id' column when the tree is written to or read from the
364             database.
365              
366             This key is optional.
367              
368             If defaults to 'mother_id'.
369              
370             =item name_col => $a_string
371              
372             This is the name to be used for the 'name' column when the tree is written to the database.
373              
374             This key is optional.
375              
376             If defaults to 'name'.
377              
378             =item table_name => $a_string
379              
380             This is the name of the database table used for reading and writing trees.
381              
382             This key is optional.
383              
384             If defaults to 'trees'.
385              
386             =item unique_id_col => $a_string
387              
388             This is the name to be used for the 'unique_id' column when the tree is written to or read from the
389             database.
390              
391             This key is optional.
392              
393             If defaults to 'unique_id'.
394              
395             =back
396              
397             =head1 Method: table name([$new_value])
398              
399             Get or set the value to be used as the name of the table when the tree is written to or read from
400             the database.
401              
402             =head1 Method: unique_id_col([$new_value])
403              
404             Get or set the value to be used as the name of the 'unique_id' column when the tree is written to
405             or read from the database.
406              
407             =head1 Method: read([$extra])
408              
409             Returns a tree of type L read from the database.
410              
411             If the optional parameter $extra is provided, then it is assumed to be an arrayref of field names.
412              
413             C is used in conjunction with C. See that method for more
414             details.
415              
416             This code shows how to save and restore an attribute of each node called 'page_id'.
417              
418             Note: In this code, the [] indicate an arrayref, not optional parameters.
419              
420             $object -> write($tree, ['page_id']);
421              
422             $shrub = $object -> read(['page_id']);
423              
424             The test program t/test.t demonstrates usage of this feature.
425              
426             =head1 Method: write_node($node, {...})
427              
428             This method is called by write(), and - naturally - you'll never call it directly.
429              
430             =head1 Method: write($tree[, $extra])
431              
432             Writes a tree of type L to the database.
433              
434             If the optional parameter $extra is provided, then it is assumed to be an arrayref of field names:
435              
436             =over 4
437              
438             =item o Each field's name is the name of a column in the table
439              
440             =item o Each field's value is extracted from the attributes of the node, via the field's name
441              
442             =item o The (field name => field value) pairs are written to each record in the table
443              
444             =back
445              
446             In particular note that you can store - in a single table - trees which both do and don't have extra
447             fields.
448              
449             Just ensure the definition of each extra column is flexible enough to handle these alternatives.
450              
451             The test program t/test.t demonstrates usage of this feature.
452              
453             This method does not return a meaningful value.
454              
455             =head1 FAQ
456              
457             =over 4
458              
459             =item What is the required table structure?
460              
461             Firstly, note that the column names used here are the defaults. By supplying suitable parameters
462             to C, or calling the appropriate method, you can use any column names you wish.
463              
464             As a minimum, you must have these fields in the table used to hold the trees:
465              
466             id $primary_key,
467             mother_id integer not null,
468             unique_id integer not null,
469             context varchar(255) not null,
470             name varchar(255) not null
471              
472             You can generate the $primary_key text using L, as is done in t/test.t.
473              
474             =item What is id?
475              
476             Strictly speaking, the id field does not have to be a primary key, but it must be unique, because
477             it's used as a hash key when a tree is read in from the database.
478              
479             The value of id is stored in each node when the tree is read in, whereas the values of context and
480             unique_id are not.
481              
482             The id of a node can be recovered from the 'attribute' hashref associated with any node, using the
483             code:
484              
485             my($id) = ${$node -> attribute}{id} || 0;
486              
487             Of course, this id (in the 'attribute' hashref) only exists if the tree has been written to the
488             database and read back in. For a brand-new node, which has never been saved, there is no id value by
489             default, hence the '|| 0'. Naturally, you're free to jam some sort of value in there yourself.
490              
491             =item What is mother_id?
492              
493             It is the id of the node which is the mother of the 'current' node. Using 'mother' rather than
494             'parent', and 'daughter' rather than 'child', is terminology I have adopted from L.
495              
496             The mother_id of the root of each tree is 0, allowing you to use 'not null' on the definition of
497             mother_id.
498              
499             This 'not null' convention is adopted from:
500              
501             Joe Celko's SQL for Smarties 2nd edition
502             Morgan Kaufmann
503             1-55860-576-2
504             Section 6.9, page 120, Design Advice for NULLs
505              
506             The mother_id of a node can be recovered from the 'attribute' hashref associated with any node,
507             using the code:
508              
509             my($mother) = $node -> mother;
510             my($id) = $mother ? ${$mother -> attribute}{id} : 0;
511              
512             =item What is unique_id?
513              
514             For a given tree (in the database), each node has the same value for context, but a unique value
515             for unique_id.
516              
517             The reason the id field is not used for this, is that nodes in one tree may be deleted, so that when
518             a second tree is written to the database, if the database reuses ids, the order of ids no longer
519             means anything.
520              
521             The module writes a node to the database before it writes that node's children. By generating a
522             unique value as the nodes are written, the module guarantees a node's unique_id will be less that
523             the unique_ids of each of its children.
524              
525             Then, when the nodes are read back in, the database is used to sort the nodes using their unique_id
526             as the sort key.
527              
528             In this manner, the order of children belonging to a node is preserved.
529              
530             The field unique_id is only unique for a given tree (in the database). The root of each tree has a
531             unique_id of 1.
532              
533             The value of id is stored in each node when the tree is read in, whereas the value of context and
534             unique_id are not.
535              
536             =item What is context?
537              
538             You give each tree some sort of identifying string, which is stored in the context field.
539              
540             For a given tree, all nodes must have the same value for this context field.
541              
542             Reading a tree means reading all records whose context matches the value you provide.
543              
544             Writing a tree means:
545              
546             =over 4
547              
548             =item * Delete
549              
550             All records whose context matches the value you provide are deleted.
551              
552             =item * Insert
553              
554             All nodes in the tree are inserted in the table.
555              
556             =back
557              
558             The reason for this 2-step process is to avoid depending on ids provided by the database, which may
559             be reused after records are deleted.
560              
561             By inserting the tree afresh each time, we can ensure the unique_id values for the given tree are
562             generated in such a way that when the records are read back in, sorted by unique_id, each mother
563             node is read before any of its daughters. This makes it easy to insert the incoming data into a new
564             tree in a reliable manner, and to guarantee daughter nodes have their order preseved throughout the
565             write-then-read cycle.
566              
567             The value of id is stored in each node when the tree is read in, whereas the value of context and
568             unique_id are not.
569              
570             =item What is name?
571              
572             Each node can have any name you wish. See L for details.
573              
574             The name of a node can be recovered with the name method associated with any node, using the code:
575              
576             my($name) = $node -> name;
577              
578             =item How do I build a tree from a text file?
579              
580             See sub build_tree() in t/test.t, and where it's called from.
581              
582             =item How do I process a single node?
583              
584             See sub find_junk() or sub find_node() in t/test.t, and where they're called from.
585              
586             =item How do I pretty-print a tree?
587              
588             See sub pretty_print() in t/test.t, and where it's called from.
589              
590             =item How do I run t/test.t?
591              
592             You can set the environment variables $DBI_DSN, $DBI_USER and $DBI_PASS, and the program will use a
593             table called 'menus'. The I table name is 'trees'.
594              
595             Or, if $DBI_DSN has no value, the program will use SQLite and a default file (i.e. database) name,
596             in the temp directory.
597              
598             =back
599              
600             =head1 Machine-Readable Change Log
601              
602             The file Changes was converted into Changelog.ini by L.
603              
604             =head1 See Also
605              
606             L. This module has its own list of See Also references.
607              
608             L. This module has its own list of See Also references.
609              
610             L.
611              
612             L.
613              
614             L.
615              
616             L.
617              
618             Thanx to the author(s) of Tree::Persist, for various ideas implemented in this module.
619              
620             L.
621              
622             =head1 Repository
623              
624             L.
625              
626             =head1 License
627              
628             This library is free software; you can redistribute it
629             and/or modify it under the same terms as Perl 5.10.0.
630              
631             For more details, see the full text of the licenses at
632             http://www.perlfoundation.org/artistic_license_1_0,
633             and http://www.gnu.org/licenses/gpl-2.0.html.
634              
635             =head1 Support
636              
637             Email the author, or log a bug on RT:
638              
639             L.
640              
641             =head1 Author
642              
643             L was written by Ron Savage Iron@savage.net.auE> in 2010.
644              
645             Home page: L.
646              
647             =head1 Copyright
648              
649             Australian copyright (c) 2010, Ron Savage.
650              
651             All Programs of mine are 'OSI Certified Open Source Software';
652             you can redistribute them and/or modify them under the terms of
653             The Artistic License, a copy of which is available at:
654             http://www.opensource.org/licenses/index.html
655              
656             =cut
657