File Coverage

blib/lib/Metabrik/String/Parse.pm
Criterion Covered Total %
statement 9 54 16.6
branch 0 34 0.0
condition 0 12 0.0
subroutine 3 8 37.5
pod 1 5 20.0
total 13 113 11.5


line stmt bran cond sub pod time code
1             #
2             # $Id$
3             #
4             # string::parse Brik
5             #
6             package Metabrik::String::Parse;
7 1     1   640 use strict;
  1         2  
  1         29  
8 1     1   5 use warnings;
  1         1  
  1         26  
9              
10 1     1   5 use base qw(Metabrik);
  1         2  
  1         856  
11              
12             sub brik_properties {
13             return {
14 0     0 1   revision => '$Revision$',
15             tags => [ qw(unstable) ],
16             author => 'GomoR ',
17             license => 'http://opensource.org/licenses/BSD-3-Clause',
18             commands => {
19             identify => [ qw(string) ],
20             to_array => [ qw($data) ],
21             to_matrix => [ qw($data) ],
22             split_by_blank_line => [ qw($data) ],
23             },
24             };
25             }
26              
27             sub to_array {
28 0     0 0   my $self = shift;
29 0           my ($data) = @_;
30              
31 0 0         $self->brik_help_run_undef_arg('to_array', $data) or return;
32 0 0         $self->brik_help_run_invalid_arg('to_array', $data, 'SCALAR') or return;
33              
34 0           my @array = split(/\n/, $data);
35              
36 0           return \@array;
37             }
38              
39             sub to_matrix {
40 0     0 0   my $self = shift;
41 0           my ($data) = @_;
42              
43 0 0         $self->brik_help_run_undef_arg('to_matrix', $data) or return;
44              
45 0 0         my $array = $self->to_array($data) or return;
46              
47 0           my @matrix = ();
48 0           for my $this (@$array) {
49 0           push @matrix, [ split(/\s+/, $this) ];
50             }
51              
52 0           return \@matrix;
53             }
54              
55             sub identify {
56 0     0 0   my $self = shift;
57 0           my ($string) = @_;
58              
59 0 0         $self->brik_help_run_undef_arg('identify', $string) or return;
60              
61 0           my $length = length($string);
62             # Truncate to 128 Bytes
63 0 0         my $subset = substr($string, 0, $length > 128 ? 128 : $length);
64              
65 0           my $identify = [ 'text' ]; # Default dump text string
66              
67 0 0 0       if ($subset =~ /^/i) {
    0 0        
    0 0        
    0          
    0          
    0          
    0          
68 0           push @$identify, 'html';
69             }
70             elsif ($subset =~ /^
71 0           push @$identify, 'xml';
72             }
73             elsif ($subset =~ /^\s*{\s+["a-zA-Z0-9:]+\s+/) {
74 0           push @$identify, 'json';
75             }
76             elsif ($string =~ /^[a-zA-Z0-9+]+={1,2}$/) {
77 0           push @$identify, 'base64';
78             }
79             elsif ($length == 32 && $string =~ /^[a-f0-9]+$/) {
80 0           push @$identify, 'md5';
81             }
82             elsif ($length == 40 && $string =~ /^[a-f0-9]+$/) {
83 0           push @$identify, 'sha1';
84             }
85             elsif ($length == 64 && $string =~ /^[a-f0-9]+$/) {
86 0           push @$identify, 'sha256';
87             }
88              
89 0           return $identify;
90             }
91              
92             sub split_by_blank_line {
93 0     0 0   my $self = shift;
94 0           my ($data) = @_;
95              
96 0 0         $self->brik_help_run_undef_arg('split_by_blank_line', $data) or return;
97 0 0         $self->brik_help_run_invalid_arg('split_by_blank_line', $data, 'ARRAY') or return;
98              
99 0           my $new = [];
100 0           my @chunks = ();
101 0           for (@$data) {
102 0 0 0       if (/^\s*$/ && @$new > 0) {
103 0           push @chunks, $new;
104 0           $new = [];
105 0           next;
106             }
107 0           push @$new, $_;
108             }
109              
110             # Read last lines before eof (no more blank lines can be found)
111 0 0         if (@$new > 0) {
112 0           push @chunks, $new;
113             }
114              
115 0           return \@chunks;
116             }
117              
118             1;
119              
120             __END__