File Coverage

lib/Log/Shiras/Types.pm
Criterion Covered Total %
statement 42 112 37.5
branch 0 30 0.0
condition n/a
subroutine 14 24 58.3
pod n/a
total 56 166 33.7


line stmt bran cond sub pod time code
1             package Log::Shiras::Types;
2             our $AUTHORITY = 'cpan:JANDREW';
3 6     6   103027 use version; our $VERSION = version->declare("v0.44.0");
  6         1280  
  6         28  
4             #~ use lib '../../';
5             #~ use Log::Shiras::Unhide qw( :InternalTypeSShirasFormat :InternalTypeSFileHash :InternalTypeSReportObject :InternalTypeSHeadeR);
6             ###InternalTypeSShirasFormat use Data::Dumper;
7             ###InternalTypeSFileHash use Data::Dumper;
8             ###InternalTypeSReportObject use Data::Dumper;
9             ###InternalTypeSHeadeR use Data::Dumper;
10 6     6   365 use utf8;
  6         6  
  6         26  
11 6     6   106 use Carp qw( confess );
  6         10  
  6         248  
12 6     6   871 use IO::File;
  6         12355  
  6         653  
13 6     6   2227 use FileHandle;
  6         3579  
  6         24  
14 6     6   2028 use Fcntl qw( :flock LOCK_EX );# SEEK_END
  6         13  
  6         593  
15 6     6   525 use MooseX::ShortCut::BuildInstance v1.42 qw( build_instance should_re_use_classes );
  6         670199  
  6         31  
16             should_re_use_classes( 1 );
17 6         34 use MooseX::Types::Moose qw(
18             ArrayRef Int Str HashRef
19             Object Undef GlobRef FileHandle
20 6     6   1918 );
  6         7  
21             #~ use MooseX::Types::Structured qw( Optional );
22 6         38 use MooseX::Types -declare =>[qw(
23             ElevenArray PosInt NewModifier ElevenInt
24             ShirasFormat TextFile HeaderString YamlFile
25             FileHash JsonFile ArgsHash ReportObject
26             NameSpace CSVFile XLSXFile XLSFile
27             XMLFile IOFileType HeaderArray
28 6     6   22018 )];#
  6         6  
29             #~ use YAML::Any qw( Dump LoadFile );
30 6     6   46343 use JSON::XS;
  6         20272  
  6         269  
31 6     6   27 use strict;
  6         6  
  6         83  
32 6     6   17 use warnings;
  6         6  
  6         130  
33 6     6   21 use lib '../../../lib', '../../lib';
  6         7  
  6         37  
34              
35             #########1 Package Variables 3#########4#########5#########6#########7#########8#########9
36              
37             my $standard_char = qr/[csduoxefgXEGbB]/; # Legacy conversions not supported
38             my $producer_char = qr/[pn%]/; # sprintf standards that don't take arguments
39             my $new_type_char = qr/[MPO]/; # M = method style, P = passed data style, O = object style
40             my $split_regex = qr/
41             ([^%]*) # inserted string
42             (%([^%]*?) # get modifiers
43             ( ($producer_char)| # get terminator characters
44             ($standard_char))) #
45             /x;
46             my $sprintf_dispatch =[
47             [ \&_append_to_string, ],# 0
48             [ \&_alt_position, \&_does_not_consume, \&_append_to_string, ], # 1
49             [ sub{ $_[1] }, ],# pass through # 2
50             [ sub{ $_[1] }, ],# pass through # 3
51             [ \&_append_to_string, \&_set_consumption, ], # 4
52             [ \&_append_to_string, \&_remove_consumption, ],# 5
53             [ \&_append_to_string, ], # 6
54             [ sub{ $_[1] }, ],# pass through # 7
55             [ sub{ $_[1] }, ],# pass through # 8
56             [ \&_append_to_string, \&_set_consumption, ], # 9
57             [ \&_append_to_string, \&_remove_consumption, ], # 10
58             [ \&_append_to_string, ],# 11
59             [ sub{ $_[1] }, ],# pass through # 12
60             [ \&_append_to_string, ], # 13
61             [ sub{ $_[1] }, ],# pass through # 14
62             [ \&_append_to_string, \&_set_consumption, ], # 15
63             [ \&_append_to_string, ], # 17
64             [ \&_test_for_position_change, \&_does_not_consume, \&_set_insert_call, ], # 18
65             [ sub{ $_[1] }, ],# pass through # 19
66             [ \&_append_to_string, \&_set_consumption, ], # 20
67             [ \&_append_to_string, ], # 21
68             [ sub{ confess "No methods here!!" }, ],# 22
69             [ sub{ confess "No methods here!!" }, ],# 23
70             ];
71             my $sprintf_regex = qr/
72             \A[%] # (required) sequence start
73             ([\s\-\+0#]{0,2}) # (optional) flag(s)
74             ([1-9]\d*\$)? # (optional) get the formatted value from
75             # some position other than the next position
76             (((\*)([1-9]\d*\$)?)? # (optional) vector flag with optional index and reference
77             (v))? # for gathering a defined vector separator
78             ( # (optional) minimum field width formatting
79             ((\*)([1-9]\d*\$)?)| # get field from input with possible position call
80             ([1-9]\d*) )? # fixed field size definition
81             ((\.)( # (optional) maximum field width formatting
82             (\*)| # get field from input with possible position call
83             ([0-9]\d*) ))? # fixed field size definition
84             ($new_type_char)? # (optional) get input from a method or passed source
85             ( # (required) conversion type
86             ($standard_char)| # standard character
87             ($producer_char) ) # producer character
88             \Z # End of the line
89             /sxmp;
90             my $shiras_format_ref = {
91             final => 1,
92             alt_input => 1,
93             bump_list => 1,
94             };
95             my $TextFileext = qr/[.](txt|csv)/;
96             my $yamlextention = qr/\.(?i)(yml|yaml)/;
97             my $jsonextention = qr/\.(?i)(jsn|json)/;
98             my $coder = JSON::XS->new->ascii->pretty->allow_nonref;#
99             my $switchboard_attributes = [ qw(
100             name_space_bounds reports buffering
101             conf_file logging_levels
102             ) ];
103             our $recursion_block = 0;
104 6     6   2919 use constant IMPORT_DEBUG => 1; # Author testing only
  6         6  
  6         15258  
105              
106             #########1 subtype Library 3#########4#########5#########6#########7#########8#########9
107              
108             subtype ElevenArray, as ArrayRef,
109             where{ scalar( @$_ ) < 13 },
110             message{ "This goes past the eleventh position! :O" };
111              
112             subtype PosInt, as Int,
113             where{ $_ >= 0 },
114             message{ "$_ is not a positive integer" };
115              
116             subtype ElevenInt, as PosInt,
117             where{ $_ < 12 },
118             message{ "This goes past eleven! :O" };
119              
120             subtype NewModifier, as Str,
121             where{ $_ =~ /\A$new_type_char\Z/sxm },
122             message{ "'$_' does not match $new_type_char" };
123              
124             subtype ShirasFormat, as HashRef,
125             where{ _has_shiras_keys( $_ ) },
126             message { $_ };
127              
128             ###InternalTypeSShirasFormat warn "You uncovered internal logging statements for the Type ShirasFormat in Log::Shiras::Types-$VERSION" if !$ENV{hide_warn};
129             coerce ShirasFormat, from Str,
130             via {
131             my ( $input, ) = @_;
132             ###InternalTypeSShirasFormat warn "passed: $input";
133             my ( $x, $finished_ref, ) = ( 1, {} );
134             my $escape_off = 1;
135             ###InternalTypeSShirasFormat warn "check for a pure sprintf string";
136             if( $input !~ /{/ ){
137             ###InternalTypeSShirasFormat warn "no need to pre parse this string ...";
138             return { final => $input };
139             }else{
140             ###InternalTypeSShirasFormat warn "manage new formats ...";
141             my $start = 1;
142             while( $input =~ /([^%]*)%([^%]*)/g ){
143             my $pre = $1;
144             my $post = $2;
145             ###InternalTypeSShirasFormat warn "pre: $pre";
146             ###InternalTypeSShirasFormat warn "post: $post";
147             if( $start ){#
148             push @{$finished_ref->{init_parse}}, $pre;
149             $start = 0;
150             }elsif( $pre ){
151             return "Coersion to 'ShirasFormat' failed for section -$pre- in " .
152             __FILE__ . " at line " . __LINE__ . ".\n";
153             }
154             if( $post =~ /^([^{]*){([^}]*)}(.)(\(([^)]*)\))?(.*)$/ ){
155             my @list = ( $1, $2, $3, $4, $5, $6 );
156             ###InternalTypeSShirasFormat warn "list:" . Dumper( @list );
157             if( !is_NewModifier( $list[2] ) ){
158             return "Coersion to 'ShirasFormat' failed because of an " .
159             "unrecognized modifier -$list[2]- found in format string -" .
160             $post . "- by ". __FILE__ . " at line " . __LINE__ . ".\n";
161             }
162             push @{$finished_ref->{alt_input}}, [ @list[1,2,4] ];
163             push @{$finished_ref->{init_parse}}, join '', @list[0,2,5];
164             }elsif( $post =~ /[{}]/ ){
165             return "Coersion to 'ShirasFormat' failed for section -$post- " .
166             "using " . __FILE__ . " at line " . __LINE__ . ".\n";
167             }else{
168             push @{$finished_ref->{init_parse}}, $post;
169             }
170             ###InternalTypeSShirasFormat warn "finished ref:" . Dumper( $finished_ref );
171             }
172             $input = join '%', @{$finished_ref->{init_parse}};
173             delete $finished_ref->{init_parse};
174             ###InternalTypeSShirasFormat warn "current sprintf ref:" . Dumper( $input );
175             }
176             ###InternalTypeSShirasFormat warn "build input array modifications ...";
177             my $parsed_length = 0;
178             my $total_length = length( $input );
179             while( $input =~ /$split_regex/g ){
180             my @list = ( $1, $2, $3, $4, $5, $6 );#
181             ###InternalTypeSShirasFormat warn "matched:" . Dumper( @list );
182             ###InternalTypeSShirasFormat warn "for segment: $&";
183             if( $list[2] and $list[4] and $list[4] eq '%' ){
184             return "Coersion to 'ShirasFormat' failed for the segment: " .
185             $list[1] . " using " . __FILE__ . " at line " .
186             __LINE__ . ".\n";
187             }
188             my $pre_string = $list[0];
189             $finished_ref->{string} .= $list[0] if $list[0];
190             $finished_ref->{new_chunk} = $list[1];
191             my $consumer_format = $list[5];
192             my $producer_format = $list[4];
193             $parsed_length +=
194             length( $finished_ref->{new_chunk} ) + length( $pre_string );
195             $input = ${^POSTMATCH};
196             my $pre_match = ${^PREMATCH};
197             my $finished_length = $total_length - length( $input );
198             ###InternalTypeSShirasFormat warn "length of chunk: $finished_ref->{new_chunk}";
199             ###InternalTypeSShirasFormat warn "parsed length: $parsed_length";
200             ###InternalTypeSShirasFormat warn "finished length: $finished_length";
201             ###InternalTypeSShirasFormat warn "pre match: $pre_match";
202             ###InternalTypeSShirasFormat warn "remaining: $input";
203             ###InternalTypeSShirasFormat warn "producer: $producer_format";
204             ###InternalTypeSShirasFormat warn "consumer: $consumer_format";
205             if( $finished_length != $parsed_length ){
206             return "Coersion to 'ShirasFormat' failed for the modified " .
207             "sprintf segment -$pre_match- using " .
208             __FILE__ . " at line " . __LINE__ . ".\n";
209             }
210             if( $producer_format or $consumer_format ){
211             # $finished_ref = _process_producer_format( $finished_ref );
212             # }elsif( $consumer_format ){
213             $finished_ref = _process_sprintf_format( $finished_ref );
214             }else{
215             delete $finished_ref->{new_chunk};
216             next;
217             }
218              
219             if( !is_HashRef( $finished_ref ) ){
220             ###InternalTypeSShirasFormat warn "fail:" . Dumper( $finished_ref );
221             return $finished_ref;
222             }
223             delete $finished_ref->{new_chunk};
224             ###InternalTypeSShirasFormat warn "current:" . Dumper( $finished_ref);
225             $x++;
226             ###InternalTypeSShirasFormat warn "current input:" . Dumper( $input );
227             }
228             ###InternalTypeSShirasFormat warn "finished ref:" . Dumper( $finished_ref );
229             ###InternalTypeSShirasFormat warn "input length: " . length( $input );
230             if( $input and $finished_ref->{string} !~ /$input$/ ){
231             $finished_ref->{string} .= $input;
232             }
233             ###InternalTypeSShirasFormat warn "reviewing:" . Dumper( $finished_ref );
234             my $parsing_string = $finished_ref->{string};
235             ###InternalTypeSShirasFormat warn "parsing_string: $parsing_string";
236             delete $finished_ref->{bump_count};
237             delete $finished_ref->{alt_position};
238             while( $parsing_string =~ /(\d+)([\$])/ ){
239             $finished_ref->{final} .= ${^PREMATCH};
240             $parsing_string = ${^POSTMATCH};
241             ###InternalTypeSShirasFormat warn "updated:" . Dumper( $finished_ref );
242             ###InternalTypeSShirasFormat warn "parsing string: $parsing_string";
243             my $digits = $1;
244             my $position = $digits - 1;
245             if( exists $finished_ref->{bump_list}->[$position] ){
246             $digits += $finished_ref->{bump_list}->[$position];
247             }
248             ###InternalTypeSShirasFormat warn "digits: $digits";
249             ###InternalTypeSShirasFormat warn "position: $position";
250             $finished_ref->{final} .= $digits;
251             $finished_ref->{final} .= '$';
252             ###InternalTypeSShirasFormat warn "updated:" . Dumper( $finished_ref );
253             }
254             $finished_ref->{final} .= $parsing_string;
255             delete $finished_ref->{string};
256             ###InternalTypeSShirasFormat warn "returning:" . Dumper( $finished_ref );
257             return $finished_ref;
258             };
259              
260             subtype TextFile, as Str,
261             message { "$_ does not have the correct suffix (\.txt or \.csv)" },
262             where { $_ =~ /$TextFileext\Z/sxm };
263              
264             subtype HeaderString, as Str,
265             where{ $_ =~ /^[a-z\_][a-z0-9\_^\n\r]*$/sxm };
266              
267             ###InternalTypeSShirasFormat warn "You uncovered internal logging statements for the Types HeaderString and HeaderArray in Log::Shiras::Types-$VERSION" if !$ENV{hide_warn};
268             coerce HeaderString, from Str,
269             via {
270             if( is_Str( $_ ) ) {
271             my $header = $_;
272             ###InternalTypeSHeadeR warn "Initital header: $header";
273             $header = lc( $header );
274             ###InternalTypeSHeadeR warn "Updated header: $header";
275             $header =~ s/\n/ /gsxm;
276             ###InternalTypeSHeadeR warn "Updated header: $header";
277             $header =~ s/\r/ /gsxm;
278             ###InternalTypeSHeadeR warn "Updated header: $header";
279             $header =~ s/\s/_/gsxm;
280             ###InternalTypeSHeadeR warn "Updated header: $header";
281             chomp $header;
282             ###InternalTypeSHeadeR warn "Final header: $header";
283             return $header;
284             } else {
285             return "Can not coerce -$_- into a 'HeaderString' since it is " .
286             "a -" . ref $_ . "- ref (not a string) using " .
287             "Log::Shiras::Types 'ShirasFormat' line " . __LINE__ . ".\n";
288             }
289             };
290              
291             subtype HeaderArray, as ArrayRef[HeaderString];
292              
293             coerce HeaderArray, from ArrayRef,
294             via {
295             my $array_ref = $_;
296             ###InternalTypeSHeadeR warn "Received data:" . Dumper( @_ );
297             my $new_ref = [];
298             for my $header ( @$array_ref ){
299             ###InternalTypeSHeadeR warn "Initital header: $header";
300             $header = lc( $header );
301             ###InternalTypeSHeadeR warn "Updated header: $header";
302             $header =~ s/\n/ /gsxm;
303             ###InternalTypeSHeadeR warn "Updated header: $header";
304             $header =~ s/\r/ /gsxm;
305             ###InternalTypeSHeadeR warn "Updated header: $header";
306             $header =~ s/\s/_/gsxm;
307             ###InternalTypeSHeadeR warn "Updated header: $header";
308             chomp $header;
309             ###InternalTypeSHeadeR warn "Final header: $header";
310             push @$new_ref, $header;
311             }
312             return $new_ref;
313             };
314              
315             subtype YamlFile, as Str,
316             where{ $_ =~ $yamlextention and -f $_ },
317             message{ $_ };
318              
319             subtype JsonFile, as Str,
320             where{ $_ =~ $jsonextention and -f $_ },
321             message{ $_ };
322              
323             subtype FileHash, as HashRef;
324             ###InternalTypeSFileHash warn "You uncovered internal logging statements for the Type FileHash in Log::Shiras::Types-$VERSION" if !$ENV{hide_warn};
325             coerce FileHash, from YamlFile,
326             via{
327             my @Array = LoadFile( $_ );
328             ###InternalTypeSFileHash warn "downloaded file:" . Dumper( @Array );
329             return ( ref $Array[0] eq 'HASH' ) ?
330             $Array[0] : { @Array } ;
331             };
332              
333             coerce FileHash, from JsonFile,
334             via{
335             ###InternalTypeSFileHash warn "input: $_";
336             open( my $fh, "<", $_ );
337             my @Array = <$fh>;
338             chomp @Array;
339             ###InternalTypeSFileHash warn "downloaded file:" . Dumper( @Array );
340             my $ref = $coder->decode( join '', @Array );
341             ###InternalTypeSFileHash warn "converted file:" . Dumper( $ref );
342             return $ref ;
343             };
344              
345             subtype ArgsHash, as HashRef,
346             where{
347             my $result = 0;
348             for my $key ( @$switchboard_attributes ){
349             if( exists $_->{$key} ){
350             $result = 1;
351             last;
352             }
353             }
354             return $result;
355             },
356             message{ 'None of the required attributes were passed' };
357              
358             coerce ArgsHash, from FileHash,
359             via{ $_ };
360              
361             subtype ReportObject, as Object,
362             where{ $_->can( 'add_line' ) },
363             message{ $_ };
364             ###InternalTypeSReportObject warn "You uncovered internal logging statements for the Type ReportObject in Log::Shiras::Types-$VERSION" if !$ENV{hide_warn};
365             coerce ReportObject, from FileHash,
366             via{
367             ###InternalTypeSReportObject warn "the passed value is:" . Dumper( @_ );
368             return build_instance( %$_ );
369             };
370              
371             subtype NameSpace, as Str,
372             where{
373             my $result = 1;
374             $result = 0 if( !$_ or $_ =~ / / );
375             return $result;
376             },
377             message{
378             my $passed = ( ref $_ eq 'ARRAY' ) ? join( '::', @$_ ) : $_;
379             return "-$passed- could not be coerced into a string without spaces";
380             };
381              
382             coerce NameSpace, from ArrayRef,
383             via{ return join( '::', @$_ ) };
384              
385             subtype CSVFile,
386             as Str,
387             where{ $_ =~ /\.(csv)$/i and -r $_};
388              
389             coerce CSVFile,
390             from Str,
391             via{ my $fh = IO::File->new;
392             $fh->open( "> $_" );# Vivify the file!
393             $fh->close;
394             return $_; };
395              
396             subtype XMLFile,
397             as Str,
398             where{ $_ =~ /\.(xml|rels)$/i and -r $_};
399              
400             subtype XLSXFile,
401             as Str,
402             where{ $_ =~ /\.x(ls(x|m)|ml)$/i and -r $_ };
403              
404             subtype XLSFile,
405             as Str,
406             where{ $_ =~ /\.xls$/i and -r $_ };
407              
408             subtype IOFileType,
409             as FileHandle;
410             #~ { class => 'IO::File' };
411              
412             #~ coerce IOFileType,
413             #~ from GlobRef,
414             #~ via{ my $fh = bless( $_, 'IO::File' );
415             #~ $fh->binmode();
416             #~ return $fh; };
417              
418             #~ coerce IOFileType,
419             #~ from CSVFile,
420             #~ via{ my $fh = IO::File->new( $_, 'r' );
421             #~ $fh->binmode();
422             #~ flock( $fh, LOCK_EX );
423             #~ return $fh; };
424              
425             #~ coerce IOFileType,
426             #~ from XLSXFile,
427             #~ via{ my $fh = IO::File->new( $_, 'r' );
428             #~ $fh->binmode();
429             #~ flock( $fh, LOCK_EX );
430             #~ return $fh; };
431              
432             #~ coerce IOFileType,
433             #~ from XLSFile,
434             #~ via{ my $fh = IO::File->new( $_, 'r' );
435             #~ $fh->binmode();
436             #~ flock( $fh, LOCK_EX );
437             #~ return $fh; };
438              
439             #~ coerce IOFileType,
440             #~ from XMLFile,
441             #~ via{ my $fh = IO::File->new( $_, 'r' );
442             #~ $fh->binmode();
443             #~ flock( $fh, LOCK_EX );
444             #~ return $fh; };
445              
446              
447             #########1 Private Methods 3#########4#########5#########6#########7#########8#########9
448              
449             sub _has_shiras_keys{
450 0     0     my ( $ref ) =@_;
451             ###InternalTypeSShirasFormat warn "passed information is:" . Dumper( $ref );
452 0           my $result = 1;
453 0 0         if( ref $ref eq 'HASH' ){
454             ###InternalTypeSShirasFormat warn "found a hash ref...";
455 0           for my $key ( keys %$ref ){
456             ###InternalTypeSShirasFormat warn "testing key: $key";
457 0 0         if( !(exists $shiras_format_ref->{$key}) ){
458             ###InternalTypeSShirasFormat warn "failed at key: $key";
459             ### <where> -
460 0           $result = 0;
461 0           last;
462             }
463             }
464             }else{
465 0           $result = 0;
466             }
467 0           return $result;
468             }
469              
470             sub _process_sprintf_format{
471 0     0     my ( $ref ) = @_;
472             ###InternalTypeSShirasFormat warn "passed information is:" . Dumper( $ref );
473 0 0         if( my @list = $ref->{new_chunk} =~ $sprintf_regex ) {
474             ###InternalTypeSShirasFormat warn "results of the next regex element are:" .Dumper( @list );
475 0           $ref->{string} .= '%';
476 0           my $x = 0;
477 0           for my $item ( @list ){
478 0 0         if( defined $item ){
479             ###InternalTypeSShirasFormat warn "processing: $item";
480             ###InternalTypeSShirasFormat warn "position: $x";
481 0           my $i = 0;
482 0           for my $method ( @{$sprintf_dispatch->[$x]} ){
  0            
483             ###InternalTypeSShirasFormat warn "running the -$i- method: $method";
484 0           $ref = $method->( $item, $ref );
485             ###InternalTypeSShirasFormat warn "updated ref:" . Dumper( $ref );
486 0 0         return $ref if ref $ref ne 'HASH';
487 0           $i++;
488             }
489             }
490 0           $x++;
491             }
492             } else {
493             $ref = "Failed to match -" . $ref->{new_chunk} .
494 0           "- as a (modified) sprintf chunk";
495             }
496             ###InternalTypeSShirasFormat warn "after _process_sprintf_format:" . Dumper( $ref );
497 0           return $ref;
498             }
499              
500             sub _process_producer_format{
501 0     0     my ( $ref ) = @_;
502             ###InternalTypeSShirasFormat warn "passed information is:" . Dumper( $ref );
503 0           $ref->{string} .= $ref->{new_chunk};
504 0           delete $ref->{new_chunk};
505             ###InternalTypeSShirasFormat warn "after _process_producer_format:" . Dumper( $ref );
506 0           return $ref;
507             }
508              
509             sub _append_to_string{
510 0     0     my ( $item, $item_ref ) = @_;
511             ###InternalTypeSShirasFormat warn "reached _append_to_string with:" . Dumper( $item );
512 0           $item_ref->{string} .= $item;
513 0           return $item_ref;
514             }
515              
516             sub _does_not_consume{
517 0     0     my ( $item, $item_ref ) = @_;
518             ###InternalTypeSShirasFormat warn "reached _does_not_consume with:" . Dumper( $item );
519 0           $item_ref->{no_primary_consumption} = 1;
520 0           return $item_ref;
521             }
522              
523             sub _set_consumption{
524 0     0     my ( $item, $item_ref ) = @_;
525             ###InternalTypeSShirasFormat warn "reached _set_consumption with:" . Dumper( $item );
526 0 0         if( !$item_ref->{no_primary_consumption} ){
527 0           push @{$item_ref->{bump_list}},
528 0 0         ((exists $item_ref->{bump_count})?$item_ref->{bump_count}:0);
529             }
530 0           delete $item_ref->{no_primary_consumption};
531 0           return $item_ref;
532             }
533              
534             sub _remove_consumption{
535 0     0     my ( $item, $item_ref ) = @_;
536             ###InternalTypeSShirasFormat warn "reached _remove_consumption with:" . Dumper( $item );
537 0           pop @{$item_ref->{bump_list}};
  0            
538 0           return $item_ref;
539             }
540              
541             sub _set_insert_call{
542 0     0     my ( $item, $item_ref ) = @_;
543             $item_ref->{alt_position} = ( $item_ref->{alt_position} ) ?
544 0 0         $item_ref->{alt_position} : 0 ;
545 0           $item_ref->{bump_count}++;
546             ###InternalTypeSShirasFormat warn "reached _set_insert_call with:" . Dumper( $item );
547             ###InternalTypeSShirasFormat warn "using position:" . Dumper( $item_ref->{alt_position} );
548             ###InternalTypeSShirasFormat warn "with new bump level:" . Dumper( $item_ref->{bump_count} );
549             my $new_ref = [
550             $item_ref->{alt_input}->[$item_ref->{alt_position}]->[1],
551 0           $item_ref->{alt_input}->[$item_ref->{alt_position}]->[0],
552             ];
553 0 0         if( $item_ref->{alt_input}->[$item_ref->{alt_position}]->[2] ){
554 0           my $dispatch = undef;
555 0           for my $value (
556             split /,|=>/,
557             $item_ref->{alt_input}->[$item_ref->{alt_position}]->[2] ){
558 0           $value =~ s/\s//g;
559 0           $value =~ s/^['"]([^'"]*)['"]$/$1/g;
560 0           push @$new_ref, $value;
561 0 0         if( $dispatch ){
562             $item_ref->{bump_count} -=
563 0 0         ( $value =~/^\d+$/ )? $value :
    0          
564             ( $value =~/^\*$/ )? 1 : 0 ;
565 0           $dispatch = undef;
566             }else{
567 0           $dispatch = $value;
568             }
569             }
570             }
571 0           $item_ref->{alt_input}->[$item_ref->{alt_position}] = { commands => $new_ref };
572             $item_ref->{alt_input}->[$item_ref->{alt_position}]->{start_at} =
573             ( exists $item_ref->{bump_list} ) ?
574 0 0         $#{$item_ref->{bump_list}} + 1 : 0 ;
  0            
575 0           $item_ref->{alt_position}++;
576             ###InternalTypeSShirasFormat warn "item ref:" . Dumper( $item_ref );
577 0           return $item_ref;
578             }
579              
580             sub _test_for_position_change{
581 0     0     my ( $item, $item_ref ) = @_;
582             ###InternalTypeSShirasFormat warn "reached _test_for_position_change with:" . Dumper( $item );
583 0 0         if( exists $item_ref->{conflict_test} ){
584             $item_ref = "You cannot call for alternative location pull -" .
585 0           $item_ref->{conflict_test} . "- and get data from the -$item- " .
586             "source in ShirasFormat type coersion at line " . __LINE__ . ".\n";
587             }
588 0           return $item_ref;
589             }
590              
591             sub _alt_position{
592 0     0     my ( $item, $item_ref ) = @_;
593             ###InternalTypeSShirasFormat warn "reached _alt_position with:" . Dumper( $item );
594 0 0         $item_ref->{conflict_test} = $item if $item;
595 0           return $item_ref;
596             }
597              
598             #########1 Phinish 3#########4#########5#########6#########7#########8#########9
599              
600             1;
601             # The preceding line will help the module return a true value
602              
603             #########1 main pod docs 3#########4#########5#########6#########7#########8#########9
604             __END__
605              
606             =head1 NAME
607              
608             Log::Shiras::Types - The Type::Tiny library for Log::Shiras
609              
610             =head1 SYNOPSIS
611              
612             #!perl
613             package Log::Shiras::Report::MyRole;
614              
615             use Modern::Perl;#suggested
616             use Moose::Role;
617             use Log::Shiras::Types v0.013 qw(
618             ShirasFormat
619             JsonFile
620             );
621              
622             has 'someattribute' =>(
623             isa => ShirasFormat,#Note the lack of quotes
624             );
625              
626             sub valuetestmethod{
627             return is_JsonFile( 'my_file.jsn' );
628             }
629              
630             no Moose::Role;
631              
632             1;
633              
634             =head1 DESCRIPTION
635              
636             This is the custom type class that ships with the L<Log::Shiras> package.
637              
638             There are only subtypes in this package! B<WARNING> These types should be
639             considered in a beta state. Future type fixing will be done with a set of tests in
640             the test suit of this package. (currently few are implemented)
641              
642             See L<MooseX::Types> for general re-use of this module.
643              
644             =head1 Types
645              
646             =head2 PosInt
647              
648             =over
649              
650             =item B<Definition: >all integers equal to or greater than 0
651              
652             =item B<Coercions: >no coersion available
653              
654             =back
655              
656             =head2 ElevenInt
657              
658             =over
659              
660             =item B<Definition: >any posInt less than 11
661              
662             =item B<Coercions: >no coersion available
663              
664             =back
665              
666             =head2 ElevenArray
667              
668             =over
669              
670             =item B<Definition: >an array with up to 12 total positions [0..11]
671             L<I<This one goes to eleven>|https://en.wikipedia.org/wiki/This_Is_Spinal_Tap>
672              
673             =item B<Coercions: >no coersion available
674              
675             =back
676              
677             =head2 ShirasFormat
678              
679             =over
680              
681             =item B<Definition: >this is the core of the L<Log::Shiras::Report::ShirasFormat> module.
682             When prepared the final 'ShirasFormat' definition is a hashref that contains three keys;
683              
684             =over
685              
686             =item B<final> - a sprintf compliant format string
687              
688             =item B<alt_input> - an arrayref of input definitions and positions for all the additional
689             'ShirasFormat' modifications allowed
690              
691             =item B<bump_list> - a record of where and how many new inputs will be inserted
692             in the passed data for formatting the sprintf compliant string
693              
694             =back
695              
696             In order to simplify sprintf formatting I approached the sprintf definition as having
697             the following sequence;
698              
699             =over
700              
701             =item B<Optional - Pre-string, > any pre-string that would be printed as it stands
702             (not interpolated)
703              
704             =item B<Required - %, >this indicates the start of a formating definition
705              
706             =item B<Optional - L<Flags|http://perldoc.perl.org/functions/sprintf.html#flags>, >
707             any one or two of the following optional flag [\s\-\+0#] as defined in the sprintf
708             documentation.
709              
710             =item B<Optional -
711             L<Order of arguments|http://perldoc.perl.org/functions/sprintf.html#order-of-arguments>, >
712             indicate some other position to obtain the formatted value.
713              
714             =item B<Optional -
715             L<Vector flag|http://perldoc.perl.org/functions/sprintf.html#vector-flag>, >to treat
716             each input character as a value in a vector then you use the vector flag with it's
717             optional vector separator definition.
718              
719             =item B<Optional -
720             L<Minimum field width|http://perldoc.perl.org/functions/sprintf.html#(minimum)-width>, >
721             This defines the space taken for presenting the value
722              
723             =item B<Optional -
724             L<Maximum field width|http://perldoc.perl.org/functions/sprintf.html#precision%2c-or-maximum-width>, >
725             This defines the maximum length of the presented value. If maximum width is smaller
726             than the minimum width then the value is truncatd to the maximum width and presented
727             in the mimimum width space as defined by the flags.
728              
729             =item B<Required -
730             L<Data type definition|http://perldoc.perl.org/functions/sprintf.html#sprintf-FORMAT%2c-LIST>, >
731             This is done with an upper or lower case letter as described in the sprintf documentation. Only
732             the letters defined in the sprintf documentation are supported. These letters close the
733             sprintf documentation segment started with '%'.
734              
735             =back
736              
737             The specific combination of these values is defined in the perldoc
738             L<sprintf|http://perldoc.perl.org/functions/sprintf.html>.
739              
740             The module ShirasFormat expands on this definitions as follows;
741              
742             =over
743              
744             =item B<Word in braces {}, > just prior to the L</Data type definition> you can
745             begin a sequence that starts with a word (no spaces) enclosed in braces. This word will
746             be the name of the source data used in this format sequence.
747              
748             =item B<Source indicator qr/[MP]/, > just after the L</Word in braces {}> you must indicate
749             where the code should look for this information. There are only two choices;
750              
751             =over
752              
753             =item B<P> - a passed value in the message hash reference. The word in braces should be an
754             exact match to a key in the message hashref. The core value used for this ShirasFormat
755             segemnt will be the value assigned to that key.
756              
757             =item B<M> - a method name to be discovered by the class. I<This method must exist at the
758             time the format is set!> When the Shiras format string is set the code will attempt to
759             locate the method and save the location for calling this method to speed up implementation of
760             ongoing formatting operations. If the method does not exist when the format string is
761             set even if it will exist before data is passed for formatting then this call will fail.
762             if you want to pass a closure (subroutine reference) then pass it as the value in the mesage
763             hash L<part
764             of the message ref|/a passed value in the message hash reference> and call it with 'P'.
765              
766             =back
767              
768             =item B<Code pairs in (), following the source indicator> often the passed information
769             is a code reference and for that code to be useful it needs to accept input. These code
770             pairs are a way of implementing the code. The code pairs must be in intended use sequence.
771             The convention is to write these in a fat comma list. There is no limit to code pairs
772             quatities. There are three possible keys for these pairs;
773              
774             =over
775              
776             =item B<m> this indicates a method call. If the code passed is actually an object with
777             methods then this will call the value of this pair as a method on the code.
778              
779             =item B<i> this indicates regular input to the method and input will be provided to a
780             method using the value as follows;
781              
782             $method( 'value' )
783              
784             =item B<l> this indicates lvalue input to the method and input will be provided to a
785             method using the value as follows;
786              
787             $method->( 'value' )
788              
789             =item B<[value]> Values to the methods can be provided in one of three ways. A B<string>
790             that will be sent to the method directly. An B<*> to indicate that the method will consume
791             the next value in the passed message array ref. Or an B<integer> indicating how many of the
792             elements of the passed messay array should be consumed. When elements of the passed
793             message array are consumed they are consumed in order just like other sprintf elements.
794              
795             =back
796              
797             When a special ShirasFormat segment is called the braces and the Source indicator are
798             manditory. The code pairs are optional.
799              
800             =item B<Coercions: >from a modified sprintf format string
801              
802             =back
803              
804             =back
805              
806             =head2 TextFile
807              
808             =over
809              
810             =item B<Definition: >a file name with a \.txt or \.csv extention that exists
811              
812             =item B<Coercions: >no coersion available
813              
814             =back
815              
816             =head2 HeaderString
817              
818             =over
819              
820             =item B<Definition: >a string without any newlines
821              
822             =item B<Coercions: >if coercions are turned on, newlines will be stripped (\n\r)
823              
824             =back
825              
826             =head2 YamlFile
827              
828             =over
829              
830             =item B<Definition: >a file name with a qr/(\.yml|\.yaml)/ extention that exists
831              
832             =item B<Coercions: >none
833              
834             =back
835              
836             =head2 JsonFile
837              
838             =over
839              
840             =item B<Definition: >a file name with a qr/(\.jsn|\.json)/ extention that exists
841              
842             =item B<Coercions: >none
843              
844             =back
845              
846             =head2 ArgsHash
847              
848             =over
849              
850             =item B<Definition: >a hashref that has at least one of the following keys
851              
852             name_space_bounds
853             reports
854             buffering
855             ignored_caller_names
856             will_cluck
857             logging_levels
858              
859             This are the primary switchboard settings.
860              
861             =item B<Coersion >from a L</JsonFile> or L</YamlFile> it will attempt to open the file
862             and turn the file into a hashref that will pass the ArgsHash criteria
863              
864             =back
865              
866             =head2 ReportObject
867              
868             =over
869              
870             =item B<Definition: >an object that passes $object->can( 'add_line' )
871              
872             =item B<Coersion 1: >from a hashref it will use
873             L<MooseX::ShortCut::BuildInstance|http://search.cpan.org/~jandrew/MooseX-ShortCut-BuildInstance/lib/MooseX/ShortCut/BuildInstance.pm>
874             to build a report object if the necessary hashref is passed instead of an object
875              
876             =item B<Coersion 2: >from a L</JsonFile> or L</YamlFile> it will attempt to open the file
877             and turn the file into a hashref that can be used in L</Coersion 1>.
878              
879             =back
880              
881             =head1 GLOBAL VARIABLES
882              
883             =over
884              
885             =item B<$ENV{hide_warn}>
886              
887             The module will warn when debug lines are 'Unhide'n. In the case where the you
888             don't want these notifications set this environmental variable to true.
889              
890             =back
891              
892             =head1 TODO
893              
894             =over
895              
896             =item * write a test suit for the types to fix behavior!
897              
898             =item * write a set of tests for combinations of %n and {string}M
899              
900             =back
901              
902             =head1 SUPPORT
903              
904             =over
905              
906             =item L<Github Log-Shiras/issues|https://github.com/jandrew/Log-Shiras/issues>
907              
908             =back
909              
910             =head1 AUTHOR
911              
912             =over
913              
914             =item Jed Lund
915              
916             =item jandrew@cpan.org
917              
918             =back
919              
920             =head1 COPYRIGHT
921              
922             This program is free software; you can redistribute
923             it and/or modify it under the same terms as Perl itself.
924              
925             The full text of the license can be found in the
926             LICENSE file included with this module.
927              
928             =head1 DEPENDANCIES
929              
930             =over
931              
932             =item L<Carp> - confess
933              
934             =item L<version>
935              
936             =item L<YAML::Any> - ( Dump LoadFile )
937              
938             =item L<JSON::XS>
939              
940             =item L<MooseX::Types>
941              
942             =item L<MooseX::Types::Moose>
943              
944             =item L<MooseX::ShortCut::BuildInstance> - 1.044
945              
946             =back
947              
948             =head1 SEE ALSO
949              
950             =over
951              
952             =item L<Type::Tiny>
953              
954             =back
955              
956             =cut
957              
958             #########1 Main POD ends 3#########4#########5#########6#########7#########8#########9