File Coverage

blib/lib/Lemonldap/Portal/Session.pm
Criterion Covered Total %
statement 3 103 2.9
branch 0 36 0.0
condition 0 5 0.0
subroutine 1 9 11.1
pod 0 5 0.0
total 4 158 2.5


line stmt bran cond sub pod time code
1             package Lemonldap::Portal::Session;
2              
3 1     1   30018 use strict;
  1         3  
  1         2252  
4              
5             require Exporter;
6              
7             our @ISA = qw(Exporter);
8              
9             # Items to export into callers namespace by default. Note: do not export
10             # names by default without a very good reason. Use EXPORT_OK instead.
11             # Do not simply export all your public functions/methods/constants.
12              
13             # This allows declaration use Lemonldap::Portal::Session ':all';
14             # If you do not need this, moving things directly into @EXPORT or @EXPORT_OK
15             # will save memory.
16             our %EXPORT_TAGS = (
17             'all' => [
18             qw(
19              
20             )
21             ]
22             );
23              
24             our @EXPORT_OK = ( @{ $EXPORT_TAGS{'all'} } );
25              
26             our @EXPORT = qw(
27              
28             );
29              
30             our $VERSION = '0.02';
31              
32             # Preloaded methods go here.
33              
34             my $parser = {
35             'ATOM' => sub {
36             my $val = shift;
37             return $val;
38             },
39             'FRACT' => sub {
40             my ( $val, $sep, $rg ) = @_;
41             my @tab = split $sep, $val;
42             return $tab[$rg];
43             },
44             'EXP' => \&replace,
45             };
46              
47             sub tokens {
48 0     0 0   my $target = shift;
49             return sub {
50 0 0   0     return [ 'ATOM', $1, $parser->{'ATOM'} ] if $target =~ /\G ([^%]+) /gcx;
51 0 0         return [ 'EXP', $1, $parser->{'EXP'} ] if $target =~ /%(.+)%/gcx;
52 0 0         return [ 'NOHUP', '', '' ] if $target =~ /\G \s+ /gcx;
53              
54 0           };
55              
56             }
57              
58             sub replace {
59 0     0 0   my ( $param, $exp, $entry ) = @_;
60 0           my %tmp = %$exp;
61 0           my ( $chaine, $sep, $pos );
62 0 0         unless ( $tmp{$param} ) {
63 0           $sep = substr( $param, -2, 1 );
64 0           $pos = substr( $param, -1, 1 );
65 0           $param = substr( $param, 0, -2 );
66             }
67 0 0         $chaine = $tmp{$param}->{valeur}
68             if ( lc( $tmp{$param}->{type} ) ) eq 'constant';
69 0 0         $chaine = $entry->dn() if ( lc( $tmp{$param}->{type} ) ) eq 'dnentry';
70 0           my @tmp_attr;
71             my @tchaine;
72 0 0         @tmp_attr = $entry->get_value( $tmp{$param}->{attribut} )
73             if ( lc( $tmp{$param}->{type} ) ) eq 'attrldap';
74 0 0         if ( $#tmp_attr == 0 ) {
75 0           $chaine = shift @tmp_attr;
76 0 0         $chaine = $parser->{'FRACT'}( $chaine, $sep, $pos ) if $sep;
77             }
78              
79             else {
80 0           foreach (@tmp_attr) {
81 0           $chaine = $_;
82 0 0         $chaine = $parser->{'FRACT'}( $chaine, $sep, $pos ) if $sep;
83 0           push @tchaine, $chaine;
84              
85             }
86              
87             }
88 0 0         return \@tchaine if @tchaine;
89 0           return $chaine;
90 0           1;
91              
92             }
93              
94             sub analyse {
95 0     0 0   my ( $ligne, $exp, $entry ) = @_;
96 0           my @res;
97 0           my $iter = tokens($ligne);
98 0           my $ref;
99 0           while ( $ref = $iter->() ) {
100 0           push @res, $ref;
101             }
102             ## now I resolv all %exp%
103 0           foreach (@res) {
104              
105 0           $_->[1] = $_->[2]( $_->[1], $exp, $entry );
106              
107             #next if ($_->[0] eq 'ATOM' ) ;
108             }
109 0           my $chaine;
110 0           foreach (@res) {
111 0 0         $chaine .= $_->[1] if $_->[1];
112              
113             }
114 0           return $chaine;
115             }
116              
117             sub analyse_multi {
118 0     0 0   my ( $ligne, $exp, $entry ) = @_;
119 0           my @res;
120 0           my $iter = tokens($ligne);
121 0           my $ref;
122 0           while ( $ref = $iter->() ) {
123 0           push @res, $ref;
124             }
125             ## now I resolv all %exp%
126 0           my @chaines;
127 0           foreach (@res) {
128              
129 0           $_->[1] = $_->[2]( $_->[1], $exp, $entry );
130              
131             #next if ($_->[0] eq 'ATOM' ) ;
132             # print "pause\n";
133             }
134 0           my $cp = 0;
135 0           foreach (@res) {
136 0 0         if ( ref $_->[1] ) {
137 0           my @t = @{ $_->[1] };
  0            
138 0           $cp = $#t + 1;
139              
140             }
141             else {
142             # correction bug multi on one line
143 0           my @t;
144 0           $t[0] = $_->[1] ;
145 0           $cp = $#t + 1;
146             }
147             }
148 0           my $i;
149             my @tchaine;
150 0           for ( $i = 0 ; $i < $cp ; $i++ ) {
151 0           my $c;
152 0           foreach (@res) {
153 0 0         if ( ref $_->[1] ) {
154 0           $c .= $_->[1]->[$i];
155             }
156 0           else { $c .= $_->[1]; }
157              
158             }
159 0           push @tchaine, $c;
160             }
161              
162 0           return \@tchaine;
163             }
164              
165             sub init {
166             ## declaration #########
167             ## grammar ##
168              
169             my $dict = {
170             'single' => sub {
171 0     0     ( my $param1, my $param2, my $expr, my $entry ) = @_;
172             return (
173 0           &analyse( $param1, $expr, $entry ),
174             &analyse( $param2, $expr, $entry )
175             );
176             },
177             'multi' => sub {
178 0     0     ( my $param1, my $param2, my $expr, my $entry ) = @_;
179             return (
180 0           &analyse_multi( $param1, $expr, $entry ),
181             &analyse_multi( $param2, $expr, $entry )
182             );
183             },
184              
185 0     0 0   };
186              
187 0           my $class = shift;
188 0           my %args;
189 0 0         if ( ref( $_[0] ) ) {
190 0           my $rf = shift @{ $_[0] };
  0            
191 0           foreach ( keys %$rf ) {
192 0           $args{$_} = $rf->{$_};
193              
194             }
195 0           shift @_;
196             }
197 0           foreach ( ( my $cle, my $val ) = (@_) ) {
198              
199 0           $args{$cle} = $val;
200             }
201 0   0       my $self = bless {
202              
203             },
204             ref($class) || $class;
205 0           %$self = ( %$self, %args );
206              
207             # return $self;
208              
209 0           my %_session;
210 0           foreach ( keys( %{ $self->{ligne} } ) ) {
  0            
211 0           my %_tsession;
212 0           my $tmp = $self->{ligne}{$_};
213 0           $tmp->{_traitement} = $dict->{ $tmp->{type} };
214              
215 0           my @res = (
216             $tmp->{_traitement}( $tmp->{cle}, $tmp->{valeur}, $self->{exp},
217             $self->{entry} ) );
218 0 0         if (@res) {
219 0 0         if ( ref( $res[0] ) ) {
220 0           foreach ( @{ $res[0] } ) {
  0            
221 0           $_tsession{$_} = shift @{ $res[1] };
  0            
222             }
223             }
224             else {
225              
226 0   0       $_tsession{ $res[0] } = $res[1] || 'NULL';
227             }
228             }
229 0 0         if ( $tmp->{primarykey} ) {
230 0           $_session{ $tmp->{primarykey} } = \%_tsession;
231             }
232 0           else { @_session{ keys %_tsession } = values %_tsession; }
233             }
234              
235 0           return \%_session;
236             }
237              
238             1;
239             __END__