File Coverage

blib/lib/ZML.pm
Criterion Covered Total %
statement 9 503 1.7
branch 0 140 0.0
condition n/a
subroutine 3 29 10.3
pod 26 26 100.0
total 38 698 5.4


line stmt bran cond sub pod time code
1             package ZML;
2              
3 1     1   28336 use warnings;
  1         3  
  1         37  
4 1     1   8 use strict;
  1         2  
  1         35  
5 1     1   6 use base 'Error::Helper';
  1         6  
  1         1048  
6              
7             =head1 NAME
8              
9             ZML - A simple, fast, and easy to read binary data storage format.
10              
11             =head1 VERSION
12              
13             Version 1.0.0
14              
15             =cut
16              
17             our $VERSION = '1.0.0';
18              
19             =head1 SYNOPSIS
20              
21             The error handling is unified between all methods. If $object->{error} is
22             ever defined after a function is ran there has been an error. A description
23             of the error can be found in $object->{errorString}. The error string is
24             always defined, but set to "" when there is no error. The error is blanked
25             after each run.
26              
27             use ZML;
28              
29             my $zml = ZML->new();
30             my $zmlstring="a=0\nb=1\n 2\n";
31             if ($zml->error){
32             print "Parsing the string failed with a error, ".$zml->{error}.
33             ", ".$zml->{errorString}."\n";
34             };
35             ...
36              
37             =head1 METHODS
38              
39             =head2 new
40              
41             Creates a new ZML object.
42              
43             my $ZMLobject=$ZML->new;
44              
45             =cut
46              
47             sub new {
48 0     0 1   my $self = {var=>{}, meta=>{}, comment=>{}, error=>undef, errorString=>""};
49              
50 0           bless $self;
51 0           return $self;
52             }
53              
54             =head2 addVar
55              
56             This adds a new meta variable for a variable. Two values are required for it.
57              
58             The first variable is the name of the variable being added.
59              
60             The second is the meeta data. This can contain any character.
61              
62             $ZMLobject->addVar("some/variable", "whatever");
63              
64             =cut
65              
66             sub addVar{
67 0     0 1   my $self=$_[0];
68 0           my $var=$_[1];
69 0           my $value=$_[2];
70              
71 0           $self->errorblank;
72              
73 0 0         if(!defined($var)){
74 0           $self->{error}=10;
75 0           $self->{errorString}="ZML addVar:10: Variable is not defined.";
76 0           $self->warn;
77 0           return undef;
78             };
79              
80             #check if the variable name is legit
81 0           my ($legit, $errorString)=$self->varNameCheck($var);
82 0 0         if( $legit ){
83 0           $self->{error}=$legit;
84 0           $self->{errorString}=$errorString;
85 0           $self->warn;
86 0           return undef;
87             }
88              
89 0           $self->{var}{$var}=$value;
90 0           return 1;
91             };
92              
93             =head2 addComment
94              
95             This adds a new comment for a variable. Three values are required for it.
96              
97             The first variable is the name of the variable the comment is being added for.
98              
99             The second is the name of the comment. This also has to be a legit variable name.
100              
101             The third is the comment. This can contain any character.
102              
103             $ZMLobject->addComment("some/variable", "comment/variable","Some fragging comment.");
104              
105             =cut
106              
107             sub addComment{
108 0     0 1   my $self=$_[0];
109 0           my $var=$_[1];
110 0           my $comment=$_[2];
111 0           my $value=$_[3];
112              
113 0           $self->errorblank;
114              
115             #check if the variable name is legit
116 0           my ($legit, $errorString)=$self->varNameCheck($var);
117 0 0         if($legit){
118 0           $self->{error}=$legit;
119 0           $self->{errorString}=$errorString;
120 0           $self->warn;
121 0           return undef;
122             }
123              
124             #check if the variable name is legit
125 0           ($legit, $errorString)=$self->varNameCheck($comment);
126 0 0         if($legit){
127 0           $self->{error}=$legit;
128 0           $self->{errorString}=$errorString;
129 0           $self->warn;
130 0           return undef;
131             }
132              
133             #add the domment
134 0 0         if(defined($self->{comment}{$var})){
135             #add it if $self->{comment}{$var}{$comment} has been added
136 0           $self->{comment}{$var}{$comment}=$value;
137             }else{
138             #add it if $self->{comment}{$var}{$comment} has not been added
139 0           $self->{comment}{$var}{$comment}={};
140 0           $self->{comment}{$var}{$comment}=$value;
141             };
142              
143 0           return 1;
144             };
145              
146             =head2 addMeta
147              
148             This adds a new meta variable for a variable. Three values are required for it.
149              
150             The first variable is the name of the variable the meta variable is being added for.
151              
152             The second is the meta variable. This also has to be a legit variable name.
153              
154             The third is the meeta data. This can contain any character.
155              
156             $ZMLobject->addMeta("some/variable", "meta/variable","whatever");
157              
158             =cut
159              
160             sub addMeta{
161 0     0 1   my $self=$_[0];
162 0           my $var=$_[1];
163 0           my $meta=$_[2];
164 0           my $value=$_[3];
165              
166 0           $self->errorblank;
167              
168             #check if the variable name is legit
169 0           my ($legit, $errorString)=$self->varNameCheck($var);
170 0 0         if($legit){
171 0           $self->{error}=$legit;
172 0           $self->{errorString}=$errorString;
173 0           $self->warn;
174 0           return undef;
175             }
176              
177             #check if the variable name is legit
178 0           ($legit, $errorString)=$self->varNameCheck($meta);
179 0 0         if($legit){
180 0           $self->{error}=$legit;
181 0           $self->{errorString}=$errorString;
182 0           $self->warn;
183 0           return undef;
184             }
185              
186             #add the domment
187 0 0         if(defined($self->{meta}{$var})){
188             #add it if $self->{comment}{$var}{$meta} has been added
189 0           $self->{meta}{$var}{$meta}=$value;
190             }else{
191             #add it if $self->{comment}{$var}{$meta} has not been added
192 0           $self->{meta}{$var}{$meta}={};
193 0           $self->{meta}{$var}{$meta}=$value;
194             };
195              
196 0           return 1;
197             };
198              
199             =head2 clearComment
200              
201             This removes a meta variable. Two values are required.
202              
203             The first is the variable name.
204              
205             $ZMLobject->clearComment("some/variable");
206            
207             =cut
208              
209             sub clearComment{
210 0     0 1   my $self=$_[0];
211 0           my $var=$_[1];
212              
213 0           $self->errorblank;
214              
215             #check if the variable name is legit
216 0           my ($legit, $errorString)=$self->varNameCheck($var);
217 0 0         if($legit){
218 0           $self->{error}=$legit;
219 0           $self->{errorString}=$errorString;
220 0           $self->warn;
221 0           return undef;
222             };
223              
224 0           delete($self->{comment}{$var});
225              
226 0           return 1;
227             };
228              
229             =head2 clearMeta
230              
231             This removes a meta. Two values are required.
232              
233             This removes all meta values for a variable.
234              
235             $ZMLobject->clearMeta("some/variable");
236            
237             =cut
238              
239             sub clearMeta{
240 0     0 1   my $self=$_[0];
241 0           my $var=$_[1];
242              
243 0           $self->errorblank;
244              
245             #check if the variable name is legit
246 0           my ($legit, $errorString)=$self->varNameCheck($var);
247 0 0         if($legit){
248 0           $self->{error}=$legit;
249 0           $self->{errorString}=$errorString;
250 0           $self->warn;
251 0           return undef;
252             };
253              
254 0           delete($self->{meta}{$var});
255              
256 0           return 1;
257             };
258              
259             =head2 delVar
260              
261             This removes a variable. The only variable required is the
262             name of the variable.
263              
264             $ZMLobject->delVar("some/variable");
265            
266             =cut
267              
268             sub delVar{
269 0     0 1   my $self=$_[0];
270 0           my $var=$_[1];
271              
272 0           $self->errorblank;
273              
274             #check if the variable name is legit
275 0           my ($legit, $errorString)=$self->varNameCheck($var);
276 0 0         if($legit){
277 0           $self->{error}=$legit;
278 0           $self->{errorString}=$errorString;
279 0           $self->warn;
280 0           return undef;
281             }
282              
283 0           delete($self->{var}{$var});
284              
285 0           return 1;
286             };
287              
288             =head2 delMeta
289              
290             This removes a meta variable. Two values are required.
291              
292             The first is the variable name.
293              
294             The second is the meta variable.
295              
296             $ZMLobject->delMeta("some/variable", "meta variable");
297            
298             =cut
299              
300             sub delMeta{
301 0     0 1   my $self=$_[0];
302 0           my $var=$_[1];
303 0           my $meta=$_[2];
304              
305 0           $self->errorblank;
306              
307             #check if the variable name is legit
308 0           my ($legit, $errorString)=$self->varNameCheck($var);
309 0 0         if($legit){
310 0           $self->{error}=$legit;
311 0           $self->{errorString}=$errorString;
312 0           $self->warn;
313 0           return undef;
314             };
315              
316             #check if the variable name is legit
317 0           ($legit, $errorString)=$self->varNameCheck($meta);
318 0 0         if($legit){
319 0           $self->{error}=$legit;
320 0           $self->{errorString}=$errorString;
321 0           $self->warn;
322 0           return undef;
323             }
324              
325 0           delete($self->{meta}{$var}{$meta});
326              
327 0           return 1;
328             };
329              
330             =head2 delComment
331              
332             This removes a comment name. Two values are required.
333              
334             The first is the variable name.
335              
336             The second is the comment name.
337              
338             $ZMLobject->delMeta("some/variable", "comment name");
339            
340             =cut
341              
342             sub delComment{
343 0     0 1   my $self=$_[0];
344 0           my $var=$_[1];
345 0           my $comment=$_[2];
346              
347 0           $self->errorblank;
348              
349             #check if the variable name is legit
350 0           my ($legit, $errorString)=$self->varNameCheck($var);
351 0 0         if($legit){
352 0           $self->{error}=$legit;
353 0           $self->{errorString}=$errorString;
354 0           $self->warn;
355 0           return undef;
356             };
357              
358             #check if the variable name is legit
359 0           ($legit, $errorString)=$self->varNameCheck($comment);
360 0 0         if($legit){
361 0           $self->{error}=$legit;
362 0           $self->{errorString}=$errorString;
363 0           $self->warn;
364 0           return undef;
365             }
366              
367 0           delete($self->{comment}{$var}{$comment});
368              
369 0           return 1;
370             }
371              
372             =head2 getVar
373              
374             Gets a value of a variable.
375              
376             my @variables=$zml->getVar("some variable");
377              
378             =cut
379              
380             sub getVar {
381 0     0 1   my ($self, $var) = @_;
382              
383 0           $self->errorblank;
384              
385             #check if the variable name is legit
386 0           my ($legit, $errorString)=$self->varNameCheck($var);
387 0 0         if($legit){
388 0           $self->{error}=$legit;
389 0           $self->{errorString}=$errorString;
390 0           $self->warn;
391 0           return undef;
392             }
393            
394 0 0         if(!defined($self->{var}{$var})){
395 0           $self->{error}="10";
396 0           $self->{errorString}="Variable '".$var."' is undefined,";
397 0           $self->warn;
398 0           return undef;
399             }
400            
401 0           return $self->{var}{$var};
402             }
403              
404             =head2 getMeta
405              
406             Gets a value for a meta variable.
407              
408             my @variables=$zml->getVar("some variable", "some meta variable");
409              
410             =cut
411              
412             sub getMeta {
413 0     0 1   my ($self, $var, $meta) = @_;
414              
415 0           $self->errorblank;
416              
417             #check if the variable name is legit
418 0           my ($legit, $errorString)=$self->varNameCheck($var);
419 0 0         if($legit){
420 0           $self->{error}=$legit;
421 0           $self->{errorString}=$errorString;
422 0           $self->warn;
423 0           return undef;
424             };
425              
426             #check if the meta variable name is legit
427 0           ($legit, $errorString)=$self->varNameCheck($meta);
428 0 0         if($legit){
429 0           $self->{error}=$legit;
430 0           $self->{errorString}=$errorString;
431 0           $self->warn;
432 0           return undef;
433             };
434            
435 0 0         if(!defined($self->{meta}{$var})){
436 0           $self->{error}="10";
437 0           $self->{errorString}="Variable '".$var."' is undefined,";
438 0           $self->warn;
439 0           return undef;
440             };
441              
442 0 0         if(!defined($self->{meta}{$var}{$meta})){
443 0           $self->{error}="10";
444 0           $self->{errorString}="Variable '".$var."' is undefined,";
445 0           $self->warn;
446 0           return undef;
447             };
448            
449 0           return $self->{meta}{$var}{$meta};
450             };
451              
452             =head2 getComment
453              
454             Gets the value for a comment
455              
456             my @variables=$zml->getComment("some variable", "some comment name");
457              
458             =cut
459              
460             sub getComment {
461 0     0 1   my ($self, $var, $comment) = @_;
462              
463 0           $self->errorblank;
464              
465             #check if the variable name is legit
466 0           my ($legit, $errorString)=$self->varNameCheck($var);
467 0 0         if($legit){
468 0           $self->{error}=$legit;
469 0           $self->{errorString}=$errorString;
470 0           $self->warn;
471 0           return undef;
472             };
473              
474             #check if the meta variable name is legit
475 0           ($legit, $errorString)=$self->varNameCheck($comment);
476 0 0         if($legit){
477 0           $self->{error}=$legit;
478 0           $self->{errorString}=$errorString;
479 0           $self->warn;
480 0           return undef;
481             };
482            
483 0 0         if(!defined($self->{comment}{$var})){
484 0           $self->{error}="10";
485 0           $self->{errorString}="Variable '".$var."' is undefined,";
486 0           $self->warn;
487 0           return undef;
488             };
489              
490 0 0         if(!defined($self->{comment}{$var}{$comment})){
491 0           $self->{error}="10";
492 0           $self->{errorString}="Variable '".$var."' is undefined,";
493 0           $self->warn;
494 0           return undef;
495             };
496            
497 0           return $self->{comment}{$var}{$comment};
498             };
499              
500             =head2 keysVar
501              
502             This gets a array containing the names of the variables.
503              
504             my @variables=$zml->keysVar();
505              
506             =cut
507              
508             sub keysVar {
509 0     0 1   my ($self, $var) = @_;
510              
511 0           $self->errorblank;
512              
513 0           my @keys=keys(%{$self->{var}});
  0            
514              
515 0           return @keys;
516             };
517              
518             =head2 keysMeta
519              
520             This gets a list of variables with metas.
521              
522             my @variables=$zml->keysMeta();
523              
524             =cut
525              
526             sub keysMeta {
527 0     0 1   my ($self, $var) = @_;
528              
529 0           $self->errorblank;
530              
531 0           my @keys=keys(%{$self->{meta}});
  0            
532              
533 0           return @keys;
534             };
535              
536             =head2 keysComment
537              
538             This gets a list of comments.
539              
540             my @variables=$zml->keysComment();
541              
542             =cut
543              
544             sub keysComment {
545 0     0 1   my ($self, $var) = @_;
546              
547 0           $self->errorblank;
548              
549 0           my @keys=keys(%{$self->{comment}});
  0            
550              
551 0           return @keys;
552             };
553              
554             =head2 keysMetaVar
555              
556             This gets a list of variables for a meta. It required one variable, which is the name
557             of the meta to get the meta variables for.
558              
559             my @variables=$zml->keysMetaVar("some variable");
560              
561             =cut
562              
563             sub keysMetaVar {
564 0     0 1   my ($self, $var) = @_;
565              
566 0           $self->errorblank;
567              
568             #check if the variable name is legit
569 0           my ($legit, $errorString)=$self->varNameCheck($var);
570 0 0         if($legit){
571 0           $self->{error}=$legit;
572 0           $self->{errorString}=$errorString;
573 0           $self->warn;
574 0           return undef;
575             }
576              
577 0           my @keys=keys(%{$self->{meta}{$var}});
  0            
578              
579 0           return @keys;
580             };
581              
582             =head2 keysCommentVar
583              
584             This gets a list of comments for a variable. It requires one arguement, which is
585             the variable to get the comments for.
586              
587             my @variables=$zml->keysCommentVar("some variable");
588              
589             =cut
590              
591             sub keysCommentVar {
592 0     0 1   my ($self, $var) = @_;
593              
594 0           $self->errorblank;
595              
596             #check if the variable name is legit
597 0           my ($legit, $errorString)=$self->varNameCheck($var);
598 0 0         if($legit){
599 0           $self->{error}=$legit;
600 0           $self->{errorString}=$errorString;
601 0           $self->warn;
602 0           return undef;
603             }
604              
605 0           my @keys=keys(%{$self->{comment}{$var}});
  0            
606              
607 0           return @keys;
608             }
609              
610             =head2 keyRegexDelComment
611              
612             This searches a the comments for a match and removes it.
613              
614             It requires two arguements. The first arguement is the regexp used
615             to match the variable. The second is a regexp to match a name.
616              
617             #checks every meta for any meta variable matching /^monkey/
618             my %removed=keyRegexDelComment("", "^monkey")
619              
620             #prints the removed
621             my @removedA=keys(%removed)
622             my $removedInt=0;
623             while(defined($removedA[$removedInt])){
624             my $mvInt=0;
625             while(defined($removed{$removedA[$removedInt]})){
626             print $removed{$removedA[$removedInt]}[$mvInt]."\n";
627            
628             $mvInt++;
629             };
630            
631             $removedInt++;
632             };
633              
634             =cut
635              
636             sub keyRegexDelComment{
637 0     0 1   my ($self, $creg, $vreg) = @_;
638            
639             #contains the removed variables
640 0           my %removed;
641            
642             #get a list of variables
643 0           my @ckeys=keys(%{$self->{comment}});
  0            
644            
645 0           my $ckeysInt=0;
646             #goes through looking for matching metas
647 0           while(defined($ckeys[$ckeysInt])){
648             #check if the key matches
649 0 0         if($ckeys[$ckeysInt] =~ /$creg/){
650 0           my @vkeys=keys(%{$self->{comment}{$ckeys[$ckeysInt]}});
  0            
651 0           my $vkeysInt=0;
652             #goes through checking the meta variables
653 0           while(defined($vkeys[$vkeysInt])){
654             #removes it if it matches
655 0 0         if($self->{comment}{$ckeys[$ckeysInt]}{$vkeys[$vkeysInt]}){
656             #adds is to the list of removed variables
657 0 0         if(!defined($removed{$ckeys[$ckeysInt]})){
658             #adds it to the removed list if the key for the meta has not been added yet
659 0           $removed{$ckeys[$ckeysInt]}=[$vkeys[$vkeysInt]];
660             }else{
661             #adds it if it has not been added yet
662 0           push(@{$removed{$ckeys[$ckeysInt]}}, $vkeys[$vkeysInt]);
  0            
663             }
664              
665 0           delete($self->{comment}{$ckeys[$ckeysInt]}{$vkeys[$vkeysInt]});
666             }
667              
668             #checks all the meta variables have been removes it if it matched
669 0           @vkeys=keys(%{$self->{comment}{$ckeys[$ckeysInt]}});
  0            
670 0 0         if(defined($vkeys[0])){
671 0           delete($self->{comment}{$ckeys[$ckeysInt]});
672             }
673              
674 0           $vkeysInt++;
675             }
676             }
677              
678 0           $ckeysInt++;
679             }
680              
681 0           return %removed;
682             }
683              
684             =head2 keyRegexDelMeta
685              
686             This searches a the metas for a match and removes it.
687              
688             It requires two arguements. The first arguement is the regexp used
689             to match the meta. The second is the regexp used to match the meta
690             variable.
691              
692             #checks every meta for any meta variable matching /^monkey/
693             my %removed=keyRegexDelMeta("", "^monkey")
694              
695             #prints the removed
696             my @removedA=keys(%removed)
697             my $removedInt=0;
698             while(defined($removedA[$removedInt])){
699             my $mvInt=0;
700             while(defined($removed{$removedA[$removedInt]})){
701             print $removed{$removedA[$removedInt]}[$mvInt]."\n";
702            
703             $mvInt++;
704             };
705            
706             $removedInt++;
707             };
708              
709             =cut
710              
711             sub keyRegexDelMeta{
712 0     0 1   my ($self, $mreg, $vreg) = @_;
713            
714             #contains the removed variables
715 0           my %removed;
716            
717             #get a list of variables
718 0           my @mkeys=keys(%{$self->{meta}});
  0            
719            
720 0           my $mkeysInt=0;
721             #goes through looking for matching metas
722 0           while(defined($mkeys[$mkeysInt])){
723             #check if the key matches
724 0 0         if($mkeys[$mkeysInt] =~ /$mreg/){
725 0           my @vkeys=keys(%{$self->{meta}{$mkeys[$mkeysInt]}});
  0            
726 0           my $vkeysInt=0;
727             #goes through checking the meta variables
728 0           while(defined($vkeys[$vkeysInt])){
729             #removes it if it matches
730 0 0         if($self->{meta}{$mkeys[$mkeysInt]}{$vkeys[$vkeysInt]}){
731             #adds is to the list of removed variables
732 0 0         if(!defined($removed{$mkeys[$mkeysInt]})){
733             #adds it to the removed list if the key for the meta has not been added yet
734 0           $removed{$mkeys[$mkeysInt]}=[$vkeys[$vkeysInt]];
735             }else{
736             #adds it if it has not been added yet
737 0           push(@{$removed{$mkeys[$mkeysInt]}}, $vkeys[$vkeysInt]);
  0            
738             };
739            
740 0           delete($self->{meta}{$mkeys[$mkeysInt]}{$vkeys[$vkeysInt]});
741             };
742            
743             #checks all the meta variables have been removes it if it matched
744 0           @vkeys=keys(%{$self->{meta}{$mkeys[$mkeysInt]}});
  0            
745 0 0         if(defined($vkeys[0])){
746 0           delete($self->{meta}{$mkeys[$mkeysInt]});
747             };
748            
749 0           $vkeysInt++;
750             };
751             };
752              
753 0           $mkeysInt++;
754             };
755              
756 0           return %removed;
757             };
758              
759             =head2 keyRegexDelVar
760              
761             This searches a the variables for a match and removes it.
762              
763             It requires one arguement, which is the regex to use.
764              
765             It returns a array of removed variables.
766              
767             #remove any variables starting with the word monkey
768             my @removed=keyRegexDelVar("^monkey")
769              
770             =cut
771              
772             sub keyRegexDelVar{
773 0     0 1   my ($self, $regex) = @_;
774            
775             #contains the removed variables
776 0           my @removed=();
777            
778             #get a list of variables
779 0           my @keys=keys(%{$self->{var}});
  0            
780            
781 0           my $keysInt=0;
782 0           while(defined($keys[$keysInt])){
783             #check if the key matches
784 0 0         if($keys[$keysInt] =~ /$regex/){
785             #add the key to the array of removed variables
786 0           push(@keys, $keys[$keysInt]);
787            
788             #removes the variable
789 0           delete($self->{var}{$keys[$keysInt]});
790             }
791            
792 0           $keysInt++;
793             }
794            
795 0           return @removed;
796             }
797              
798             =head2 parse
799              
800             This parses a string in the ZML format. The only variable it requires is the
801             string that contains the data.
802              
803             =cut
804              
805             sub parse {
806 0     0 1   my ($self, $zmlstring)= @_;
807              
808             #blanks any errors
809 0           $self->errorblank;
810              
811 0           my %zml;
812            
813             #breaks down the zblstring per line
814 0           my @rawdata=split(/\n/, $zmlstring);
815              
816 0           my $rdInt=0;
817 0           my $prevVar=undef;
818 0           my $prevVar2=undef;
819 0           my $prevVar2type=undef;
820 0           while (defined($rawdata[$rdInt])) {
821              
822             #handles it if it is a prevarious variable
823 0 0         if ($rawdata[$rdInt] =~ /^\ /) {
824             #clean it up
825 0           chomp($rawdata[$rdInt]);
826 0           $rawdata[$rdInt]=~s/^\ //;
827              
828             #ignore it if there is no previous variable
829 0 0         if (defined($prevVar)) {
830 0 0         if (defined($prevVar2)) {
831 0           $self->{$prevVar2type}{$prevVar}{$prevVar2}=
832             $self->{$prevVar2type}{$prevVar}{$prevVar2}."\n".$rawdata[$rdInt];
833             }else {
834 0           $self->{var}{$prevVar}=$self->{var}{$prevVar}."\n".$rawdata[$rdInt];
835             }
836             }
837              
838             }else {
839            
840 0           my @split1=split(/\=/, $rawdata[$rdInt], 2);
841              
842             #handles it for a regular variable
843 0 0         if (!($split1[0] =~ /^\#/)) {
844 0           $prevVar=$split1[0];
845 0           $prevVar2=undef;
846 0           $prevVar2type=undef;
847              
848             #check if the variable name is legit
849 0           my ($legit, $errorString)=$self->varNameCheck($prevVar);
850 0 0         if($legit){
851 0           $self->{error}=$legit;
852 0           $self->{errorString}=$errorString;
853 0           $self->warn;
854 0           return undef;
855             }
856              
857 0           chomp($split1[1]);
858              
859 0           $self->{var}{$prevVar}=$split1[1];
860             }
861              
862             #handles a comment
863 0 0         if ($split1[0] =~ /^##/){
864 0           $prevVar=$split1[0];
865 0           $prevVar=~s/^\#\#//;
866 0           $prevVar2type='comment';
867              
868 0           my @split2=split(/\=/, $split1[1], 2);
869            
870 0           $prevVar2=$split2[0];
871              
872             #check if the variable name is legit
873 0           my ($legit, $errorString)=$self->varNameCheck($prevVar);
874 0 0         if($legit){
875 0           $self->{error}=$legit;
876 0           $self->{errorString}=$errorString;
877 0           return undef;
878             }
879             #check if the comment name is legit
880 0           ($legit, $errorString)=$self->varNameCheck($prevVar2);
881 0 0         if($legit){
882 0           $self->{error}=$legit;
883 0           $self->{errorString}=$errorString;
884 0           return undef;
885             }
886            
887 0           chomp($split2[1]);
888              
889 0 0         if (!defined($self->{$prevVar2type}{$prevVar})) {
890 0           $self->{$prevVar2type}{$prevVar}={};
891             }
892              
893 0           $self->{$prevVar2type}{$prevVar}{$prevVar2}=$split2[1];
894             }
895              
896             #handles a comment
897 0 0         if ($split1[0] =~ /^#!/){
898 0           $prevVar=$split1[0];
899 0           $prevVar=~s/^\#\!//;
900 0           $prevVar2type='meta';
901              
902 0           my @split2=split(/\=/, $split1[1], 2);
903            
904 0           $prevVar2=$split2[0];
905            
906             #check if the variable name is legit
907 0           my ($legit, $errorString)=$self->varNameCheck($prevVar);
908 0 0         if($legit){
909 0           $self->{error}=$legit;
910 0           $self->{errorString}=$errorString;
911 0           return undef;
912             }
913             #check if the meta name is legit
914 0           ($legit, $errorString)=$self->varNameCheck($prevVar2);
915 0 0         if($legit){
916 0           $self->{error}=$legit;
917 0           $self->{errorString}=$errorString;
918 0           return undef;
919             }
920              
921 0           chomp($split2[1]);
922              
923 0 0         if (!defined($self->{$prevVar2type}{$prevVar})) {
924 0           $self->{$prevVar2type}{$prevVar}={};
925             }
926              
927 0           $self->{$prevVar2type}{$prevVar}{$prevVar2}=$split2[1];
928             }
929              
930             }
931              
932 0           $rdInt++;
933             }
934              
935 0           return 1;
936             };
937              
938             =head2 string
939              
940             This function creates a string out of a the object.
941              
942             my $string=$zml->string;
943              
944             =cut
945              
946             sub string{
947 0     0 1   my ($self, $var) = @_;
948              
949 0           $self->errorblank;
950              
951             #used to store the generated string
952 0           my $string="";
953              
954             #generate the portion of the string for the comments
955 0           my @keys=keys(%{$self->{comment}});
  0            
956 0           my $keysInt=0;
957 0           while(defined($keys[$keysInt])){
958 0           my $comment=$keys[$keysInt];
959            
960             #builds string for comments
961 0           my @commentKeys=keys(%{$self->{comment}{$comment}});
  0            
962 0           my $commentKeysInt=0;
963 0           while(defined($commentKeys[$commentKeysInt])){
964 0           my $commentVar=$commentKeys[$commentKeysInt];
965 0           my $data=$self->{comment}{$comment}{$commentVar};
966              
967             #sets it to '' if it is not defined... this will prevent
968             #s/\n/\n /g from erroring
969 0 0         if (!defined($data)) {
970 0           $data='';
971             }
972            
973             #turns the data contained in the comment into a storable string
974 0           $data=~s/\n/\n /g ;
975              
976 0           $string=$string."##".$comment."=".$commentVar."=".$data."\n";
977              
978 0           $commentKeysInt++;
979             };
980 0           $keysInt++;
981             };
982              
983             #generate the portion of the string for the metas
984 0           @keys=keys(%{$self->{meta}});
  0            
985 0           $keysInt=0;
986 0           while(defined($keys[$keysInt])){
987 0           my $meta=$keys[$keysInt];
988            
989             #builds string for
990 0           my @metaKeys=keys(%{$self->{meta}{$meta}});
  0            
991 0           my $metaKeysInt=0;
992 0           while(defined($metaKeys[$metaKeysInt])){
993 0           my $metaVar=$metaKeys[$metaKeysInt];
994 0           my $data=$self->{meta}{$meta}{$metaVar};
995              
996             #sets it to '' if it is not defined... this will prevent
997             #s/\n/\n /g from erroring
998 0 0         if (!defined($data)) {
999 0           $data='';
1000             }
1001            
1002             #turns the data contained in the meta into a storable string
1003 0           $data=~s/\n/\n /g ;
1004              
1005 0           $string=$string."#!".$meta."=".$metaVar."=".$data."\n";
1006              
1007 0           $metaKeysInt++;
1008             };
1009 0           $keysInt++;
1010             };
1011              
1012             #generate the portion of the string for the variables
1013 0           @keys=keys(%{$self->{var}});
  0            
1014 0           $keysInt=0;
1015              
1016 0           while(defined($keys[$keysInt])){
1017 0           my $var=$keys[$keysInt];
1018              
1019 0           my $data=$self->{var}{$var};
1020              
1021             #sets it to '' if it is not defined... this will prevent
1022             #s/\n/\n /g from erroring
1023 0 0         if (!defined($data)) {
1024 0           $data='';
1025             }
1026              
1027             #turns the data contained in the meta into a storable string
1028 0           $data=~s/\n/\n /g ;
1029              
1030 0           $string=$string.$var."=".$data."\n";
1031              
1032 0           $keysInt++;
1033             };
1034              
1035 0           return $string;
1036             };
1037              
1038             =head2 valRegexDelComment
1039              
1040             This searches the comments for ones that have a value matching the regex.
1041              
1042             It requires one arguement, which is the regex to use.
1043              
1044             It returns a array of removed variables.
1045              
1046             #removes any variable in which the value matches /^monkey/
1047             my %removed=keyRegexDelMeta("^monkey")
1048              
1049             #prints the removed
1050             my @removedA=keys(%removed)
1051             my $removedInt=0;
1052             while(defined($removedA[$removedInt])){
1053             my $mvInt=0;
1054             while(defined($removed{$removedA[$removedInt]})){
1055             print $removed{$removedA[$removedInt]}[$mvInt]."\n";
1056            
1057             $mvInt++;
1058             };
1059            
1060             $removedInt++;
1061             };
1062              
1063             =cut
1064              
1065             sub valRegexDelComment{
1066 0     0 1   my ($self, $regex) = @_;
1067            
1068             #contains the removed variables
1069 0           my %removed;
1070              
1071             #get a list of variables
1072 0           my @keys=keys(%{$self->{var}});
  0            
1073              
1074 0           my $keysInt=0;
1075 0           while(defined($keys[$keysInt])){
1076 0           my @keys2=keys(%{$self->{var}{$keys[$keysInt]}});
  0            
1077 0           my $keys2Int=0;
1078 0           while(defined($keys2[$keys2Int])){
1079             #tests if the value equals the regexp
1080 0 0         if($self->{meta}{$keys[$keysInt]}{$keys2[$keys2Int]} =~ /$regex/){
1081             #adds is to the list of removed variables
1082 0 0         if(!defined($removed{$keys2[$keys2Int]})){
1083             #adds it to the removed list if the key for the meta has not been added yet
1084 0           $removed{$keys[$keysInt]}=[$keys2[$keys2Int]];
1085             }else{
1086             #adds it if it has not been added yet
1087 0           push(@{$removed{$keys[$keysInt]}}, $keys2[$keys2Int]);
  0            
1088             }
1089              
1090 0           delete($self->{var}{$keys[$keysInt]}{$keys2[$keys2Int]});
1091             }
1092              
1093 0           $keys2Int++;
1094             }
1095              
1096             #checks all the meta variables have been removes it if it matched
1097 0           @keys2=keys(%{$self->{var}{$keys[$keysInt]}});
  0            
1098 0 0         if(defined($keys2[0])){
1099 0           delete($self->{var}{$keys[$keysInt]});
1100             }
1101            
1102 0           $keysInt++;
1103             }
1104            
1105 0           return %removed;
1106             }
1107              
1108              
1109             =head2 valRegexDelMeta
1110              
1111             This searches the variables for ones that have a value matching the regex.
1112              
1113             It requires one arguement, which is the regex to use.
1114              
1115             It returns a array of removed variables.
1116              
1117             #removes any variable in which the value matches /^monkey/
1118             my %removed=keyRegexDelMeta("^monkey")
1119              
1120             #prints the removed
1121             my @removedA=keys(%removed)
1122             my $removedInt=0;
1123             while(defined($removedA[$removedInt])){
1124             my $mvInt=0;
1125             while(defined($removed{$removedA[$removedInt]})){
1126             print $removed{$removedA[$removedInt]}[$mvInt]."\n";
1127            
1128             $mvInt++;
1129             };
1130            
1131             $removedInt++;
1132             };
1133              
1134             =cut
1135              
1136             sub valRegexDelMeta{
1137 0     0 1   my ($self, $regex) = @_;
1138            
1139             #contains the removed variables
1140 0           my %removed;
1141            
1142             #get a list of variables
1143 0           my @keys=keys(%{$self->{meta}});
  0            
1144            
1145 0           my $keysInt=0;
1146 0           while(defined($keys[$keysInt])){
1147 0           my @keys2=keys(%{$self->{meta}{$keys[$keysInt]}});
  0            
1148 0           my $keys2Int=0;
1149 0           while(defined($keys2[$keys2Int])){
1150             #tests if the value equals the regexp
1151 0 0         if($self->{meta}{$keys[$keysInt]}{$keys2[$keys2Int]} =~ /$regex/){
1152             #adds is to the list of removed variables
1153 0 0         if(!defined($removed{$keys2[$keys2Int]})){
1154             #adds it to the removed list if the key for the meta has not been added yet
1155 0           $removed{$keys[$keysInt]}=[$keys2[$keys2Int]];
1156             }else{
1157             #adds it if it has not been added yet
1158 0           push(@{$removed{$keys[$keysInt]}}, $keys2[$keys2Int]);
  0            
1159             };
1160              
1161 0           delete($self->{meta}{$keys[$keysInt]}{$keys2[$keys2Int]});
1162             };
1163              
1164 0           $keys2Int++;
1165             };
1166              
1167             #checks all the meta variables have been removes it if it matched
1168 0           @keys2=keys(%{$self->{meta}{$keys[$keysInt]}});
  0            
1169 0 0         if(defined($keys2[0])){
1170 0           delete($self->{meta}{$keys[$keysInt]});
1171             };
1172            
1173 0           $keysInt++;
1174             };
1175            
1176 0           return %removed;
1177             };
1178              
1179             =head2 valRegexDelVar
1180              
1181             This searches the variables for ones that have a value matching the regex.
1182              
1183             It requires one arguement, which is the regex to use.
1184              
1185             It returns a array of removed variables.
1186              
1187             #remove any variables starting with the word monkey
1188             my @removed=valRegexDelVar("^monkey")
1189              
1190             =cut
1191              
1192             sub valRegexDelVar{
1193 0     0 1   my ($self, $regex) = @_;
1194            
1195             #contains the removed variables
1196 0           my @removed=();
1197            
1198             #get a list of variables
1199 0           my @keys=keys(%{$self->{var}});
  0            
1200            
1201 0           my $keysInt=0;
1202 0           while(defined($keys[$keysInt])){
1203             #check if the key matches
1204 0 0         if($self->{var}{$keys[$keysInt]} =~ /$regex/){
1205             #add the key to the array of removed variables
1206 0           push(@keys, $keys[$keysInt]);
1207            
1208             #removes the variable
1209 0           delete($self->{var}{$keys[$keysInt]});
1210             };
1211            
1212 0           $keysInt++;
1213             };
1214            
1215 0           return @removed;
1216             };
1217              
1218             =head2 varNameCheck
1219              
1220             This checks a variable name to see if it is legit. It requires
1221             one variable, which the name of the variable. It returns two
1222             values.
1223              
1224             The first is a integer which represents the of the error. If
1225             it is false, there is no error.
1226              
1227             The second return is the string that describes the error.
1228              
1229             my ($legit, $errorString)=varNameCheck($name);
1230              
1231             =cut
1232              
1233             #checks the config name
1234             sub varNameCheck{
1235 0     0 1   my ($self, $name) = @_;
1236              
1237             #make sure it is defined
1238 0 0         if (!defined($name)) {
1239 0           return('10', 'No name defined');
1240             }
1241              
1242             #checks for ,
1243 0 0         if($name =~ /,/){
1244 0           return("11", "variavble name,'".$name."', contains ','");
1245             };
1246            
1247             #checks for /.
1248 0 0         if($name =~ /\/\./){
1249 0           return("1", "variavble name,'".$name."', contains '/.'");
1250             };
1251              
1252             #checks for //
1253 0 0         if($name =~ /\/\//){
1254 0           return("2", "variavble name,'".$name."', contains '//'");
1255             };
1256              
1257             #checks for ../
1258 0 0         if($name =~ /\.\.\//){
1259 0           return("3", "variavble name,'".$name."', contains '../'");
1260             };
1261              
1262             #checks for /..
1263 0 0         if($name =~ /\/\.\./){
1264 0           return("4", "variavble name,'".$name."', contains '/..'");
1265             };
1266              
1267             #checks for ^./
1268 0 0         if($name =~ /^\.\//){
1269 0           return("5", "variavble name,'".$name."', matched /^\.\//");
1270             };
1271              
1272             #checks for /$
1273 0 0         if($name =~ /\/$/){
1274 0           return("6", "variavble name,'".$name."', matched /\/$/");
1275             };
1276              
1277             #checks for ^/
1278 0 0         if($name =~ /^\//){
1279 0           return("7", "variavble name,'".$name."', matched /^\//");
1280             };
1281              
1282             #checks for \\n
1283 0 0         if($name =~ /\n/){
1284 0           return("8", "variavble name,'".$name."', matched /\\n/");
1285             };
1286              
1287             #checks for
1288 0 0         if($name =~ /=/){
1289 0           return("9", "variavble name,'".$name."', matched /=/");
1290             };
1291              
1292 0           return('0', "");
1293             };
1294              
1295             =head1 ZML FORMAT
1296              
1297             There is no whitespace.
1298              
1299             A line starting with a " " is a continuation of the last variable.
1300              
1301             A line starting with ## indicates it is a comment.
1302              
1303             A line starting with a #! indicates it is a meta.
1304              
1305             Any line not starting with a /^#/ or " " is a variable.
1306              
1307             =head2 comments
1308              
1309             A line starting with ## indicates it is a comment, as stated above.
1310              
1311             It is broken down into three parts, variable, comment name, and the value. Each is sperated
1312             by a "=". Any thing after the second "=" is considered to be part of the value.
1313              
1314             =head2 meta
1315              
1316             A line starting with #! indicates it is a comment, as stated above.
1317              
1318             It is broken down into three parts, meta, meta variable, and data. Each is sperated
1319             by a "=". The first field is the meta. The second is the meta variable. The third is the value.
1320              
1321             =head2 variable
1322              
1323             Any line not starting with a /^#/ or " " is a variable, as stated above.
1324              
1325             It is broken down into two parts seperated by a "=". Any thing after the "=" is considered
1326             part of the value.
1327              
1328             =head2 multi-line data
1329              
1330             Any line matching /^ / is considered to be a continuation of the last value section of
1331             the value part of the variable. When a string is created s/\n/\n /g is ran over the
1332             value to transform it to a storable state.
1333              
1334             =head1 variable naming
1335              
1336             A variable name is considered non-legit if it matches any of the following regexs.
1337              
1338             /,/
1339             /\/\./
1340             /\/\//
1341             /\.\.\//
1342             /\/\.\./
1343             /^\.\//
1344             /\/$/
1345             /^\//
1346             /\n/
1347             /=/
1348              
1349             =head1 ERROR HANDLING/CODES
1350              
1351             This module uses L for error handling. Below are the
1352             error codes returned by the error method.
1353              
1354             =head2 1
1355              
1356             The variable name matches /\/\./.
1357              
1358             =head2 2
1359              
1360             The variable name matches /\/\//.
1361              
1362             =head2 3
1363              
1364             The variable name matches /\.\.\//.
1365              
1366             =head2 4
1367              
1368             The variable name matches /\/\.\./.
1369              
1370             =head2 5
1371              
1372             The variable name matches /^\.\//.
1373              
1374             =head2 6
1375              
1376             The variable name matches /\/$/.
1377              
1378             =head2 7
1379              
1380             The variable name matches /^\//.
1381              
1382             =head2 8
1383              
1384             The variable name matches /\n/.
1385              
1386             =head2 9
1387              
1388             The variable name matches /=/.
1389              
1390             =head2 10
1391              
1392             Undefined variable.
1393              
1394             =head2 11
1395              
1396             This means the variable name matches /,/.
1397              
1398             =cut
1399              
1400             =head1 AUTHOR
1401              
1402             Zane C. Bowers-Hadley, C<< >>
1403              
1404             =head1 BUGS
1405              
1406             Please report any bugs or feature requests to C, or through
1407             the web interface at L. I will be notified, and then you'll
1408             automatically be notified of progress on your bug as I make changes.
1409              
1410             =head1 SUPPORT
1411              
1412             You can find documentation for this module with the perldoc command.
1413              
1414             perldoc ZML
1415              
1416              
1417             You can also look for information at:
1418              
1419             =over 4
1420              
1421             =item * RT: CPAN's request tracker
1422              
1423             L
1424              
1425             =item * AnnoCPAN: Annotated CPAN documentation
1426              
1427             L
1428              
1429             =item * CPAN Ratings
1430              
1431             L
1432              
1433             =item * Search CPAN
1434              
1435             L
1436              
1437             =back
1438              
1439             =head1 COPYRIGHT & LICENSE
1440              
1441             Copyright 2012 Zane C. Bowers-Hadley, all rights reserved.
1442              
1443             This program is free software; you can redistribute it and/or modify it
1444             under the same terms as Perl itself.
1445              
1446              
1447             =cut
1448              
1449             1; # End of ZML