File Coverage

blib/lib/NetSDS/Util/Struct.pm
Criterion Covered Total %
statement 18 58 31.0
branch 0 16 0.0
condition 0 6 0.0
subroutine 6 11 54.5
pod 5 5 100.0
total 29 96 30.2


line stmt bran cond sub pod time code
1             package NetSDS::Util::Struct;
2             ########################################################################
3             # Misc Struct routines
4             #
5             ########################################################################
6              
7             =head1 NAME
8              
9             NetSDS::Util::Struct - data structure convertors
10              
11             =head1 SYNOPSIS
12              
13             use NetSDS::Util::Struct;
14              
15             ...
16              
17             my $str = dump_to_row($some_structure);
18              
19              
20             =head1 DESCRIPTION
21              
22             NetSDS::Util::Struct module contains different utilities for data structures processing.
23              
24             =cut
25              
26 2     2   4919 use 5.8.0;
  2         6  
  2         90  
27 2     2   9 use warnings 'all';
  2         4  
  2         76  
28 2     2   9 use strict;
  2         2  
  2         53  
29              
30 2     2   7 use base 'Exporter';
  2         2  
  2         152  
31              
32 2     2   8 use version; our $VERSION = "1.044";
  2         3  
  2         10  
33              
34             our @EXPORT = qw(
35             dump_to_string
36             dump_to_row
37             arrays_to_hash
38             to_array
39             merge_hash
40             );
41              
42 2         1263 use Scalar::Util qw(
43             blessed
44             reftype
45 2     2   170 );
  2         3  
46              
47              
48             #***********************************************************************
49              
50             =head1 EXPORTED METHODS
51              
52             =over
53              
54             =item B
55              
56             Returns cleaned dump to scalar.
57              
58             =cut
59              
60             #-----------------------------------------------------------------------
61             sub dump_to_string {
62 0 0   0 1   my $dmp = Data::Dumper->new( ( scalar(@_) > 1 ) ? [ \@_ ] : \@_, ['DUMP'] );
63 0           $dmp->Terse(0);
64 0           $dmp->Deepcopy(0);
65 0           $dmp->Sortkeys(1);
66 0           $dmp->Quotekeys(0);
67 0           $dmp->Indent(1);
68 0           $dmp->Pair(': ');
69 0           $dmp->Bless('obj');
70 0           return $dmp->Dump();
71             }
72              
73             #***********************************************************************
74              
75             =item B
76              
77             Returns cleaned dump to scalar.
78              
79             =cut
80              
81             #-----------------------------------------------------------------------
82             sub dump_to_row {
83              
84 0     0 1   my $str = dump_to_string(@_);
85              
86 0 0         if ( $str =~ s/^\s*\$DUMP\s+=\s+[{\[]\s+//s ) {
87 0           $str =~ s/\s+[}\]];\s+$//s;
88             } else {
89 0           $str =~ s/^\s*\$DUMP\s+=\s+//s;
90 0           $str =~ s/\s;\s+$//s;
91             }
92 0           $str =~ s/\$DUMP/\$/g;
93 0           $str =~ s/\s+/ /g;
94 0           $str =~ s/\\'/'/g;
95 0           $str =~ s/\\undef/undef/g;
96 0           $str =~ s/\\(\d)/$1/g;
97              
98 0           return $str;
99             }
100              
101             #***********************************************************************
102              
103             =item B
104              
105             =cut
106              
107             #-----------------------------------------------------------------------
108             sub to_array {
109 0     0 1   my ($data) = @_;
110              
111 0 0         if ( is_ref_array($data) ) {
    0          
    0          
112 0           return $data;
113             } elsif ( is_ref_hash($data) ) {
114 0           return [ keys %{$data} ];
  0            
115             } elsif ( defined($data) ) {
116 0           return [$data];
117             } else {
118 0           return $data;
119             }
120             }
121              
122             #***********************************************************************
123              
124             =item B - translate arrays to hash
125              
126             Parameters: references to keys array and values array
127              
128             Return: hash
129              
130             If @$keys_ref is longer than @$values_ref - rest of keys filled with
131             C values.
132              
133             If @$keys_ref is shorter than @$values_ref - rest of values are discarded.
134              
135             If any of parameters isn't array reference then C will return.
136              
137             Example:
138              
139             my %h = array2hash(['fruit','animal'], ['apple','horse']);
140              
141             Result should be a hash:
142              
143             (
144             fruit => 'apple',
145             animal => 'horse'
146             )
147              
148             =cut
149              
150             #-----------------------------------------------------------------------
151             sub arrays_to_hash {
152 0     0 1   my ( $keys_ref, $values_ref ) = @_;
153              
154 0 0 0       return undef unless ( is_ref_array($keys_ref) and is_ref_array($values_ref) );
155              
156 0           my %h = ();
157              
158 0           for ( my $i = 0 ; $i < scalar(@$keys_ref) ; $i++ ) {
159 0 0         $h{ $keys_ref->[$i] } = defined( $values_ref->[$i] ) ? $values_ref->[$i] : undef;
160             }
161              
162 0           return %h;
163             }
164              
165             #***********************************************************************
166              
167             =item B - merge two hashes
168              
169             Parameters: references to target and source hashes.
170              
171             This method adds source hash to target one and return value as a result.
172              
173             =cut
174              
175             #-----------------------------------------------------------------------
176             sub merge_hash {
177 0     0 1   my ( $trg, $src ) = @_;
178              
179 0           while ( my ( $key, $val ) = each( %{$src} ) ) {
  0            
180 0 0 0       if ( is_ref_hash($val) and is_ref_hash( $trg->{$key} ) ) {
181 0           merge_hash( $trg->{$key}, $val );
182             } else {
183 0           $trg->{$key} = $val;
184             }
185             }
186              
187 0           return $trg;
188             }
189              
190             #**************************************************************************
191             1;
192             __END__