File Coverage

blib/lib/Grips/Cmd.pm
Criterion Covered Total %
statement 21 423 4.9
branch 0 186 0.0
condition 0 68 0.0
subroutine 7 45 15.5
pod 7 21 33.3
total 35 743 4.7


line stmt bran cond sub pod time code
1             # Grips::Cmd.pm
2             #
3             # Copyright (c) 2002 DIMDI . All rights reserved.
4             #
5             # This module is free software; you can redistribute it and/or modify it under
6             # the same terms as Perl itself, i.e. under the terms of either the GNU General
7             # Public License or the Artistic License, as specified in the F file.
8             package Grips::Cmd;
9              
10 1     1   22758 use strict;
  1         2  
  1         49  
11 1     1   5 use warnings;
  1         2  
  1         30  
12 1     1   5 use Carp;
  1         6  
  1         58  
13 1     1   1477 use IO::Socket;
  1         42428  
  1         5  
14 1     1   649 use Data::Dumper;
  1         1  
  1         45  
15             #use Parse::RecDescent;
16 1     1   879 use Grips::Gripsrc;
  1         7714  
  1         35  
17            
18 1     1   8 use vars qw($AUTOLOAD @EXPORT_OK $VERSION);
  1         1  
  1         7745  
19              
20             require Exporter;
21              
22             our @ISA = qw(Exporter);
23              
24             $VERSION = "1.10";
25              
26             @EXPORT_OK = qw(checkGripsResponse);
27              
28             my $gscGrammar = q (
29             response : assign(s)
30             {
31             my $response = {};
32             my $key;
33             my $value;
34             my $str = "";
35            
36             for my $assign (@{$item[1]}) {
37            
38             $key = $assign->[0];
39             $value = $assign->[1];
40            
41             if (@$key == 1) {
42             if (ref $key->[0] eq 'ARRAY') {
43             $response->{$key->[0]->[0]}->[$key->[0]->[1]] = $value;
44             } else {
45             $response->{$key->[0]} = $value;
46             }
47             } else {
48             $str .= '$response';
49             for (my $i = 0; $i < @$key - 1; $i++) {
50            
51             if (ref $key->[$i] eq 'ARRAY') {
52             $str .= "->{'$key->[$i]->[0]'}->[$key->[$i]->[1]]";
53             } else {
54             $str .= "->{'$key->[$i]'}";
55             }
56             }
57            
58             if (ref $key->[@$key - 1] eq 'ARRAY') {
59             $str .= "->{'" . $key->[@$key - 1]->[0] . "'}->[" . $key->[@$key - 1]->[1] . "] = q($value);\n";
60             } else {
61             $str .= "->{'" . $key->[@$key - 1] ."'} = q ($value);\n";
62             }
63             }
64             }
65            
66             eval($str);
67             $response;
68             }
69              
70             assign : /\x05/ key '=' value data(s?)
71             {
72             my $value = $item[4] . join "", @{$item[5]};
73             $value ||= "";
74             chomp $value;
75             [$item[2], $value];
76             }
77              
78             key : /^/ kLevel(s)
79             {
80             $item[2];
81             }
82              
83             kLevel : /(\$??\w)+/ '(' /\d+/ ')' dot(?)
84             {
85             [$item[1], $item[3] - 1];
86             }
87             | /(\$??\w)+/ dot(?)
88             {
89             $item[1];
90             }
91              
92             value : /[^\x04\x05]*/
93            
94             data : /\x04/ /.*/ {
95             $item[2]
96             }
97            
98             dot : '.'
99             );
100              
101             #$::RD_TRACE = 1;
102             my $gscParser; # = Parse::RecDescent->new ($gscGrammar);
103              
104             sub new
105             {
106 0     0 1   my $pkg = shift;
107 0           my %params = @_;
108 0           my $port;
109             my $host;
110 0           my $sock;
111 0           my $ok = 1;
112              
113 0 0         $params{sessionID} = _generateSessionID() unless ($params{sessionID});
114              
115 0 0         $port = $params{port} or $port = 5101;
116 0 0         $host = $params{host} or $host = "app01testgrips.dimdi.de";
117              
118 0 0         $sock = IO::Socket::INET->new(PeerAddr => $host,
119             PeerPort => $port,
120             Proto => "tcp",
121             Type => SOCK_STREAM)
122              
123             or $ok = 0;
124            
125 0 0         unless ($ok) {
126 0           carp "Couldn't connect to $host:$port. Message $@\n";
127 0           return undef;
128             }
129              
130             my $self = bless
131             {
132             _sessionID => $params{sessionID},
133             _sock => $sock,
134             _port => $port,
135             _host => $host,
136             _baseID => undef,
137             _trID => 0,
138 0   0       _newResponseSyntax => $params{newResponseSyntax} || 0,
139              
140             }, $pkg;
141              
142 0           return $self;
143             }
144              
145             sub login
146             {
147 0     0 0   my $self = shift;
148 0           my %params = @_;
149 0           my $arr = [];
150              
151 0           push (@$arr, "request=" . $self->getSessionID() . ".Login");
152              
153 0 0         unless ($params{user}) {
154 0           my $h = Grips::Gripsrc->lookup($self->getHost());
155            
156 0 0         unless ($h) {
157 0           my $u;
158            
159 0 0         if ($ENV{USER}) {
160 0           $u = "user" . $ENV{USER} . "!";
161             } else {
162 0           $u = '[unknown user] (if no user could be found, the .gripsrc-method cannot work - are you using Grips::Cmd in a CGI environment?)';
163             }
164            
165 0           croak "Couldn't find host " . $self->getHost() . " in .gripsrc file of $u";
166             }
167            
168 0           (undef, $params{user}, $params{pwd}) = $h->iup();
169             }
170              
171 0           push @$arr, "user=$params{user}";
172 0 0         push @$arr, "pwd=$params{pwd}" if ($params{pwd});
173 0 0         push @$arr, "new_response_syntax=CBI_YES" if $self->{_newResponseSyntax};
174 0 0         push @$arr, "switch_port=CBI_YES" if ($params{switch_port});
175              
176 0           return $self->_sendRequest($arr, $params{debug});
177             }
178              
179             sub connectionIsAlive {
180 0     0 1   my $self = shift;
181            
182 0           my $sock = $self->_getSock();
183 0           my $tmp = "";
184 0           my @rawResponse = ();
185 0           my $retVal;
186             my $debug;
187            
188             # falls das dieses Modul nutzende script $/ kaputt macht, setze es hier wieder
189             # auf den Standard, sonst gibst Aerger mit der response aus dem socket!!!
190 0           local $/ = "\n";
191            
192 0           eval {
193             # send Request
194 0           print $sock "\x0A";
195            
196             # get response: die Antwort kommt zeilenweise aus dem socket
197             do
198 0           {
199 0           $tmp = <$sock>;
200 0 0         croak "Something went wrong while getting answer from Socket (possibly a grips timeout occurred). Answer string not defined. Session ID: " . $self->getSessionID() . '.' unless (defined($tmp));
201 0           push @rawResponse, $tmp;
202             } while ($tmp !~ m/^\}$/);
203            
204 0           $rawResponse[0] =~ s/\{//;
205            
206 0           $retVal = $self->_parseWithRegex(\@rawResponse, $debug);
207             # $retVal = _parseRecDecent(\@rawResponse, $debug);
208             };
209 0 0         return 0 if $@;
210 0   0       return $retVal->{status} eq 'CBI_SYNTAX_ERR' || 0;
211             }
212              
213             sub getHost
214             {
215 0     0 1   my $self = shift;
216 0           return $self->{_host};
217             }
218              
219             sub getPort
220             {
221 0     0 1   my $self = shift;
222 0           return $self->{_port};
223             }
224              
225             sub _checkParams {
226 0     0     my $p = shift;
227 0           my $m = shift;
228 0           my $goDie = shift;
229            
230 0 0         if (exists $p->{_}) {
231 0 0         $p->{grips_object_name} = $p->{_} unless exists $p->{grips_object_name};
232             }
233            
234 0 0         carp "Parameter name 'request_id' is deprecated, please use 'grips_object_name' instead. Warned" if exists $p->{request_id};
235 0 0 0       unless (exists $p->{grips_object_name} || exists $p->{request_id}) {
236 0 0         if ($goDie) {
237 0           croak "No method '$m()' or calling '$m()' without parameter 'grips_object_name' or '_' is not possible, died";
238             } else {
239 0           carp "No method '$m()' or calling '$m()' without parameter 'grips_object_name' or '_' is deprecated, warned";
240             }
241             }
242             }
243              
244             sub getAttributes
245             {
246 0     0 0   my $self = shift;
247 0           my %params = @_;
248 0           my $arr = [];
249              
250 0 0         push @{$params{attribute}}, $params{attributes} if (exists $params{attributes});
  0            
251 0           _checkParams(\%params, "getAttributes");
252              
253 0   0       my $obj = $params{grips_object_name} || $params{request_id} || $self->getSessionID();
254 0           push (@$arr, "request=" . $obj . ".GetAttributes");
255              
256 0 0         if (exists $params{attribute}) {
257 0           for (1 .. @{$params{attributes}})
  0            
258             {
259 0           push (@$arr, "attribute($_)=" . $params{attributes}->[$_ - 1]);
260             }
261 0           push (@$arr, "attributes_num=" . scalar(@{$params{attributes}}));
  0            
262             }
263              
264 0           return $self->_sendRequest($arr, $params{debug});
265             }
266              
267             sub setAttribute
268             {
269 0     0 0   my $self = shift;
270 0           my %params = @_;
271 0           my $arr;
272              
273 0           _checkParams(\%params, "setAttribute");
274              
275 0   0       my $obj = $params{grips_object_name} || $params{request_id} || $self->getSessionID();
276 0           push @$arr, "request=" . $obj . ".SetAttribute";
277              
278 0           for my $key (keys %params) {
279 0 0         next if $key eq "debug";
280 0 0         next if $key eq "_";
281 0 0         next if $key eq "grips_object_name";
282 0 0         next if $key eq "request_id";
283            
284 0           push @$arr, "$key=" . $params{$key};
285             }
286              
287 0           return $self->_sendRequest($arr, $params{debug});
288             }
289              
290             sub reflect
291             {
292 0     0 0   my $self = shift;
293 0           my %params = @_;
294              
295 0           return $self->_sendRequest(["request=$params{object}.Reflect","$params{id}=$params{value}"], $params{debug});
296             }
297              
298             sub defineBase
299             {
300 0     0 0   my $self = shift;
301 0           my %params = @_;
302 0           my $dbs_num = -1;
303 0           my $dbs = "";
304 0   0       my $obj = $params{grips_object_name} || $self->getSessionID();
305 0           my $arr = ["request=" . $obj . ".DefineBase"];
306              
307 0           _checkParams(\%params, "defineBase");
308              
309 0 0         $params{id} = _generateBaseID() unless ($params{id});
310 0           $self->_setBaseID($params{id});
311              
312 0           push @$arr, "id=$params{id}";
313 0 0         push @$arr, "model=$params{model}" if $params{model};
314 0 0         push @$arr, "type=$params{type}" if $params{type};
315 0 0         push @$arr, "access=$params{access}" if $params{access};
316 0 0         push @$arr, "domain=$params{domain}" if $params{domain};
317 0 0         push @$arr, "model=$params{model}" if $params{model};
318 0 0         push @$arr, "name=$params{name}" if $params{name};
319              
320 0 0         if (exists($params{db}))
321             {
322 0           push @{$params{dbs}}, @{$params{db}};
  0            
  0            
323             }
324              
325 0 0 0       croak "No list of databases" if ((!exists($params{dbs})) or (@{$params{dbs}} == 0));
  0            
326              
327 0           $dbs_num = @{$params{dbs}};
  0            
328              
329 0           push @$arr, "dbs_num=$dbs_num";
330              
331 0           for (0 .. @{$params{dbs}} - 1) {
  0            
332 0           push @$arr, "db(" . ($_ + 1) . ")=" . $params{dbs}->[$_];
333             }
334              
335 0 0         if (exists $params{db_access}) {
336 0           for (0 .. @{$params{db_access}} - 1) {
  0            
337 0           push @$arr, "db_access(" . ($_ + 1) . ")=" . $params{db_access}->[$_];
338             }
339             }
340              
341 0           return $self->_sendRequest($arr, $params{debug});
342             }
343              
344             sub storeDocument_deprecated
345             {
346 0     0 0   my $self = shift;
347 0           my %params = @_;
348 0           my $items_num = -1;
349 0           my $dbs = "";
350 0   0       my $obj = $params{grips_object_name} || $params{request_id};
351 0           my $arr = ["request=" . $obj . ".StoreDocument"];
352              
353 0 0         carp "Parameter name 'request_id' is deprecated, please use 'grips_object_name' instead!" if exists $params{request_id};
354              
355 0           push @$arr, "mode=$params{mode}";
356 0 0         push @$arr, "unlock=$params{unlock}" if $params{unlock};
357 0           push @$arr, "doc.key=$params{'doc.key'}";
358              
359 0 0 0       croak "No list of paths" if ((!exists($params{path})) or (@{$params{path}} == 0));
  0            
360 0 0 0       croak "No list of values" if ((!exists($params{value})) or (@{$params{value}} == 0));
  0            
361 0 0         croak "Numbers of paths and values differ" if (@{$params{path}} != @{$params{value}});
  0            
  0            
362              
363 0 0         if (exists($params{value}))
364             {
365 0           push @{$params{values}}, @{$params{value}};
  0            
  0            
366             }
367              
368 0 0         if (exists($params{path}))
369             {
370 0           push @{$params{paths}}, @{$params{path}};
  0            
  0            
371             }
372              
373 0           $items_num = @{$params{values}};
  0            
374              
375 0           push @$arr, "items_num=$items_num";
376              
377 0           for (0 .. @{$params{paths}} - 1)
  0            
378             {
379 0           push @$arr, "path(" . ($_ + 1) . ")=" . $params{paths}->[$_];
380 0           push @$arr, "value(" . ($_ + 1) . ")=" . $params{value}->[$_];
381             }
382              
383 0           return $self->_sendRequest($arr, $params{debug});
384             }
385              
386             sub open
387             {
388 0     0 0   my $self = shift;
389 0           my %params = @_;
390 0           my $arr = [];
391              
392 0 0         carp "Parameter name 'base' is deprecated, please use 'grips_object_name' instead!" if exists $params{base};
393 0           _checkParams(\%params, "open");
394            
395 0 0 0       $params{_} = $params{grips_object_name} || $params{base} || $self->_getBaseID() unless exists $params{_};
396              
397 0           push @$arr, "request=$params{_}.Open";
398 0           fillRequestArr(\%params, $arr);
399 0           return $self->_sendRequest($arr, $params{debug});
400             }
401              
402             sub search
403             {
404 0     0 0   my $self = shift;
405 0           my %params = @_;
406 0           my $base = $self->_getBaseID();
407 0           my $resId = "";
408 0           my $reqParams = [];
409            
410 0 0         carp "Parameter name 'base' is deprecated, please use 'grips_object_name' instead!" if exists $params{base};
411 0           _checkParams(\%params, "search");
412            
413 0   0       my $obj = $params{grips_object_name} || $params{request_id};
414 0 0         $base = $obj if $obj;
415            
416 0 0 0       unless ($params{query} or $params{"query.string"}) {
417 0           carp "No or empty query string!";
418 0           return;
419             }
420              
421 0           push @$reqParams, "request=$base.Search";
422              
423 0 0         if (ref $params{query} eq 'HASH') {
424 0 0         croak "parameter 'query' must have key 'string'" unless exists $params{query}{string};
425 0 0         $params{query}{lang} = 'CBI_NATIVE' unless exists $params{query}{lang};
426              
427 0           push @$reqParams, "query.lang=$params{query}{lang}";
428 0           push @$reqParams, "query.string=$params{query}{string}";
429 0 0         push @$reqParams, "query.mode=$params{query}{mode}" if exists $params{query}{mode};
430             } else {
431 0   0       my $qStr = $params{'query.string'} || $params{query};
432            
433 0 0         $params{"query.lang"} = "CBI_NATIVE" unless $params{"query.lang"};
434            
435 0           push @$reqParams, "query.lang=CBI_NATIVE";
436 0           push @$reqParams, "query.string=$qStr";
437 0 0         push @$reqParams, "query.mode=$params{'query.mode'}" if exists ($params{'query.mode'});
438             }
439              
440 0 0         if ($params{'result.id'}) {
441 0           push @$reqParams, "result.id=$params{'result.id'}";
442             }
443              
444 0           return $self->_sendRequest($reqParams, $params{debug});
445             }
446              
447             sub getDocs_deprecated
448             {
449 0     0 0   my $self = shift;
450 0           my %params = @_;
451              
452 0           my $arr = [];
453              
454 0 0         unless ($params{statementID})
455             {
456 0           carp "No statement ID";
457 0           return undef;
458             }
459              
460 0           push @$arr, "request=$params{statementID}.GetDocs";
461              
462 0 0         if ($params{fieldList})
463             {
464 0           my $str = "";
465              
466 0           foreach (@{$params{fieldList}})
  0            
467             {
468 0           $str .= $_ . ';';
469             }
470              
471 0           $str =~ s/;$//;
472 0           push @$arr, "req_modifier=$str";
473             }
474              
475 0 0         push @$arr, "subset=$params{subset}" if ($params{subset});
476              
477 0           return $self->_sendRequest($arr, $params{debug});
478             }
479              
480             sub close
481             {
482 0     0 0   my $self = shift;
483 0           my %params = @_;
484            
485 0   0       my $obj = $params{grips_object_name} || $params{base} || $self->_getBaseID();
486              
487 0 0         carp "Parameter name 'base' is deprecated, please use 'grips_object_name' instead!" if exists $params{base};
488 0           _checkParams(\%params, "close");
489              
490 0           return $self->_sendRequest(["request=$obj.Close"], $params{debug});
491             }
492              
493             sub DELETE
494             {
495 0     0     my $self = shift;
496 0 0         $self->_getSock()->close() or carp "Couldn't close socket: $@\n";
497             }
498              
499             sub logout
500             {
501 0     0 0   my $self = shift;
502 0           my %params = @_;
503              
504 0   0       my $obj = $params{grips_object_name} || $self->getSessionID();
505 0           return $self->_sendRequest(["request=" . $obj . ".Logout"], $params{debug});
506             }
507              
508             sub getResults
509             {
510 0     0 0   my $self = shift;
511 0           my %params = @_;
512              
513 0   0       my $obj = $params{grips_object_name} || $params{base} || $self->_getBaseID();
514              
515 0 0         carp "Parameter name 'base' is deprecated, please use 'grips_object_name' instead!" if exists $params{base};
516 0           _checkParams(\%params, "getResults");
517              
518 0           return $self->_sendRequest(["request=" . $obj . ".GetResults"], $params{debug});
519             }
520              
521             sub deleteResult
522             {
523 0     0 0   my $self = shift;
524 0           my %params = @_;
525              
526 0   0       my $obj = $params{grips_object_name} || $params{base} || $self->_getBaseID();
527            
528 0 0 0       $params{'result.id'} = $params{result}{id} if (exists $params{result} and ref ($params{result}) eq 'HASH');
529              
530 0 0         carp "Parameter name 'base' is deprecated, please use 'grips_object_name' instead!" if exists $params{base};
531 0           _checkParams(\%params, "deleteResult");
532              
533 0           return $self->_sendRequest(["request=" . $obj . ".DeleteResult", "result.id=" . $params{"result.id"}], $params{debug});
534             }
535              
536             sub checkGripsResponse {
537 0     0 1   my $type = shift;
538 0           my $response = shift;
539 0           my $status = shift;
540            
541 0   0       $status ||= 'CBI_OK';
542            
543 0 0 0       if ($response->{status} and $response->{status} ne $status) {
544 0           my $msg = "grips returned $response->{status} in request $response->{request}. Message was\n $response->{message}.";
545            
546 0 0         if ($type eq "HARD") {
    0          
547 0           croak $msg;
548             } elsif ($type eq "SOFT") {
549 0           carp $msg;
550             } else {
551 0           croak "Unknown type $type. Please use 'HARD' or 'SOFT'!";
552             }
553             }
554            
555 0           return $response;
556             }
557              
558             sub _generateSessionID
559             {
560             # return time() . $$;
561 0     0     my ($sec,$min,$hour,$mday,$mon,$year,undef,undef,undef) = localtime();
562              
563 0           return ($year + 1900 .
564             sprintf ("%02u", $mon + 1) .
565             sprintf ("%02u", $mday) .
566             sprintf ("%02u", $hour) .
567             sprintf ("%02u", $min) .
568             sprintf ("%02u", $sec) .
569             "-" .
570             substr(rand(), 2, 5));
571             }
572              
573             sub _getTransactionID
574             {
575 0     0     my $self = shift;
576 0           return sprintf ("%07u", ++$self->{_trID});
577             }
578              
579             sub gscDirect {
580 0     0 1   my $self = shift;
581 0           my $data = shift;
582 0           my $debug = shift; # wenn true, werden debugging-ausgaben erstellt
583              
584 0           return $self->_sendRequest($data, $debug, 1);
585             }
586              
587             sub _sendRequest
588             {
589 0     0     my $self = shift;
590 0           my $req = shift;
591 0           my $debug = shift;
592 0           my $processGscDirect = shift; # wenn true, wird die unverarbeitete, textbasierte gsc-response als array oder ref. auf array zurückgeliefert
593              
594 0           my $retVal;
595 0           my $sock = $self->_getSock();
596 0           my $out = "\{";
597 0           my $respStr = "";
598 0           my $rawResponse = [];
599              
600             # falls das dieses Modul nutzende script $/ kaputt macht, setze es hier wieder
601             # auf den Standard, sonst gibst Aerger mit der response aus dem socket!!!
602            
603             # TODO: geht noch nicht, wahrscheinlich ist der socket auch nach timeout noch offen
604 0 0         croak "Session ID " . $self->getSessionID() . " lost connection to socket!" unless ($sock->connected());
605              
606 0 0         $debug = 0 unless $debug;
607              
608             # send Request
609 0           $out .= "CBI_REQUEST=" . $self->getSessionID() . "." . $self->_getTransactionID() . "\n";
610              
611 0           foreach (@$req){
612 0           chomp;
613 0           s/\x0D//;
614 0           $out .= "$_\x0A";
615             }
616              
617 0           $out .= "\}\x0A";
618              
619 0 0         print STDERR $out if ($debug > 1);
620              
621 0           print $sock $out;
622              
623             # get response
624 0           local $/ = "\n}\n";
625              
626 0           $respStr = <$sock>;
627              
628 0           $rawResponse = $self->_getRawResponse($respStr);
629              
630 0 0         if ($processGscDirect) {
631 0           $_ .= "\n" for @$rawResponse;
632 0 0         print STDERR @$rawResponse if $debug > 1;
633 0           return $rawResponse;
634             }
635              
636 0 0         $rawResponse->[0] =~ s/\{// if @$rawResponse;
637              
638 0           $retVal = $self->_parseWithRegex($rawResponse, $debug);
639              
640 0 0         print STDERR Dumper $retVal if ($debug > 2);
641              
642 0           return $retVal;
643             }
644              
645             sub _getRawResponse {
646 0     0     my $self = shift;
647 0           my $rStr = shift;
648 0           my $rawResp = [];
649              
650 0 0         if ($self->{_newResponseSyntax}) {
651 0           @$rawResp = split /\n\.\n/, $rStr;
652 0           s/^\.\././ for @$rawResp;
653             } else {
654 0           @$rawResp = split /\n/, $rStr;
655             }
656              
657 0           return $rawResp;
658             }
659              
660       0     sub _benchMark {
661             # use Benchmark::Timer;
662             #
663             # my $rawResponse = shift;
664             # my $debug = shift;
665             #
666             # my $t = Benchmark::Timer->new(skip => 1);
667             #
668             # for(0 .. 20) {
669             # $t->start('old');
670             # &_parseWithRegex($rawResponse, $debug);
671             # $t->stop;
672             # }
673             # print "\n";
674             # $t->report;
675             #
676             # $t = Benchmark::Timer->new(skip => 1);
677             #
678             # for(0 .. 20) {
679             # $t->start('new');
680             # &_parseRecDecent($rawResponse, $debug);
681             # $t->stop;
682             # }
683             #
684             # $t->report;
685             }
686              
687             # schnell, aber prinzipiell anfällig (wenn auch lang erprobt)
688             sub _parseWithRegex {
689 0     0     my $self = shift;
690 0           my $assigns = shift;
691 0           my $debug = shift;
692 0           my $retVal = {};
693 0           my $respPar = "";
694              
695 0 0         if ($self->{_newResponseSyntax}) {
696 0           for (@$assigns) {
697 0 0         _gsc2perl(\$_, $retVal) if ($_);
698             }
699             } else {
700 0           for (@$assigns) {
701 0 0         next if (/^\}$/);
702 0 0         print STDERR "$_\n" if ($debug);
703            
704 0 0         unless (/^[\w\.\(\)\$#-]+=/) {
705 0           $respPar .= $_;
706             } else {
707 0 0         _gsc2perl(\$respPar, $retVal) if ($respPar);
708 0           $respPar = $_;
709             }
710             }
711             }
712              
713 0 0         _gsc2perl(\$respPar, $retVal) if ($respPar);
714 0           return $retVal;
715             }
716              
717             # sauber, aber je nach response ca. 10 - 50x langsamer als _parseWithRegex
718             sub _parseRecDecent {
719 0     0     my $assigns = shift;
720 0           my $debug = shift;
721 0           my $gscResponse;
722            
723 0           for (@$assigns) {
724 0 0         print "$_" if ($debug);
725            
726 0 0         unless (/^[\w\.\(\)\$#]+=/) {
727 0           $gscResponse .= "\x04" . $_;
728             } else {
729 0           $gscResponse .= "\x05" . $_;
730             }
731             }
732              
733             # chomp $gscResponse;
734             # $gscResponse =~ s/\}$//;
735              
736             # print $$response, "\nis ";
737             # print "NOT " unless $gscParser->response($$response);
738             # print "a valid gsc-response\n";
739              
740 0           $gscParser->response($gscResponse);
741             }
742              
743             sub _gsc2perl
744             {
745 0     0     my $respPar = shift;
746 0           my $retVal = shift;
747 0           my $k;
748             my $v;
749            
750             # print "RESPPAR=", $$respPar, "\n";
751            
752             # die Antwort des CBI-Demons wird hier in einen String mit einer
753             # verschachtelten Perl-Datenstruktur konvertiert. Grob gesagt werden
754             # Zahlen "(1)" und "#1" zu Array-Indices und Punkte "." zu Referenzen
755             # auf Hashkeys. Das Ganze wird dann per eval zu Perl gemacht.
756             # Besser waere es, hier Parse::RecDescent zu benutzen, aber ...
757             # never change a running program :-)
758             # print $$respPar, "\n";
759 0 0         if ($$respPar =~ /^(.*?)=(.*\S*.*)/ms)
760             {
761 0           $k = $1;
762 0           $v = $2;
763 0           chomp $v;
764             # print "$k ---> $v\n";
765              
766 0           $k = '{\'' . $k . '\'}';
767 0           $k =~ s!(\d+)\)\.!($1 - 1) . ']->{\''!eg;
  0            
768 0           $k =~ s!(\d+)\)!($1 - 1) . ']'!eg;
  0            
769 0           $k =~ s/\#(\d+)/'\'}->[' . ($1 - 1) . ']'/eg;
  0            
770 0           $k =~ s/\./'\}\-\>\{'/g;
771 0           $k =~ s/\(/'\}\-\>\[/g;
772             # $k =~ s/\$//g;
773 0           $k =~ s/\]'\}$/\]/;
774             # $k =~ s/(\w+-\w+)/\'$1\'/g; # hab ich das mal für "p-group" gemacht???
775            
776             # *** falls Anfuehrungszeichen etc. drin sind, gibt es Probleme
777             # *** beim eval, daher alles unpack()en, später pack()en
778             # *** q() geht nicht, wenn in $v eine ungerade Anzahl von Klammern vorkommt
779             # print "$k ---> $v\n\n";
780 0           $v = unpack ("H*", $v);
781 0           _cleanRetVal($retVal, $k);
782             # sieh nach ob das in $k befindlich Perlgebilde als key schon
783             # existiert, wenn nein, schreib es
784 0           eval "unless (\$retVal->$k) {\$retVal->$k = \'$v\'; \$retVal->$k = pack(\"H*\", \$retVal->$k)}";
785             }
786             }
787              
788             # leider gibt es bei Periodengruppen immer eine Art Überschrift, die genauso
789             # heisst, wie die danach folgende Liste, also etwas TEIL vs. TEIL(1)... etc.
790             # diese Überschriften lassen sich, wenn einmal in $retVal abgelegt, nicht mehr
791             # durch eine Referenz auf einen Array überschreiben. Daher werden solche Keys
792             # wieder gelöscht
793             #
794             #doc.TEIL=
795             #doc.TEIL(1).STFC1=
796             #doc.TEIL(1).STFC1(1).STFNR1=00023
797             #doc.TEIL(1).STFC1_num=1
798             #doc.TEIL_num=1
799              
800             sub _cleanRetVal {
801 0     0     my $retVal = shift;
802 0           my $keyStr = shift;
803            
804             # print "\nKEYSTR=", $keyStr, "\n";
805            
806 0           my @keys = split '->', $keyStr;
807 0           my $chain = '';
808            
809 0           for (@keys) {
810 0           $chain .= '->' . $_;
811 0           eval "delete \$retVal" . $chain . " if (exists \$retVal" . $chain . " and !ref \$retVal" . $chain . " and \$retVal" . $chain . " =~ /^\\s*\$/)";
812             # print "delete \$retVal" . $chain . " if (exists \$retVal" . $chain . " and !ref \$retVal" . $chain . " and \$retVal" . $chain . " =~ /^\\s*\$/)\n";
813             }
814             }
815              
816             sub getSessionID
817             {
818 0     0 1   my $self = shift;
819              
820 0           return $self->{_sessionID};
821             }
822              
823             sub _getSock
824             {
825 0     0     my $self = shift;
826              
827 0           return $self->{_sock};
828             }
829              
830             sub _getBaseID
831             {
832 0     0     my $self = shift;
833              
834 0           return $self->{_baseID};
835             }
836              
837             sub _setBaseID
838             {
839 0     0     my $self = shift;
840 0           my $base = shift;
841              
842 0           $self->{_baseID} = $base;
843             }
844              
845             sub _generateBaseID()
846             {
847 0     0     my $self = shift;
848              
849 0           return "bas1";
850             }
851              
852             sub AUTOLOAD
853             {
854 0     0     my $self = shift;
855 0           my %params = @_;
856 0           my $response = {};
857 0           my $sub = $AUTOLOAD;
858 0           my $tmp = "";
859              
860 0           $sub =~ s/.*:://;
861 0           $sub = ucfirst $sub;
862              
863 0 0         if ($sub eq "DESTROY"){return;}
  0            
864              
865 0           my $arr = [];
866            
867 0           _checkParams(\%params, $sub, 1);
868            
869 0   0       my $obj = $params{grips_object_name} || $params{request_id};
870              
871             #*** Spezialbehandlungen um die Benutzung bequemer zu machen:
872              
873             #*** GetField()
874 0 0         $params{path} = uc($params{path}) if (lc($sub) eq "getfield");
875              
876             #*** ...
877              
878 0           push @$arr, "request=$obj." . $sub;
879              
880 0           fillRequestArr(\%params, $arr);
881            
882 0           return $self->_sendRequest($arr, $params{debug});
883             }
884              
885             sub fillRequestArr {
886 0     0 0   my $params = shift;
887 0           my $arr = shift;
888            
889 0           while (my ($k, $v) = each %$params) {
890 0 0         next if ($k eq "debug");
891 0 0         next if ($k eq "request_id");
892 0 0         next if ($k eq "grips_object_name");
893 0 0         next if ($k eq "_");
894            
895 0           _perl2gsc($v, $k, $arr);
896             }
897             }
898              
899             sub _perl2gsc {
900 0     0     my $data = shift;
901 0           my $prefix = shift;
902 0           my $arr = shift;
903 0           my $tmp;
904             my $out;
905 0           my $dot;
906            
907 0   0       $prefix ||= "";
908              
909 0 0         unless (defined $data) {
910 0           $data = "";
911 0           carp "Value of $prefix is undefined, I convert it to '' (empty string). Warning issued";
912             }
913            
914 0 0 0       if (!defined ref($data) or ref($data) eq "") {
    0          
    0          
    0          
915 0           $out .= $prefix . "=" . $data;
916 0           push @$arr, $out;
917            
918             } elsif (ref($data) eq "SCALAR") {
919 0           $out .= $prefix . "=" . $$data;
920 0           push @$arr, $out;
921            
922             } elsif (ref($data) eq "ARRAY") {
923 0           for (1..@$data) {
924 0           $dot = "";
925             # $dot = ref $data->[$_ - 1] ? "." : "";
926 0           $out .= _perl2gsc($data->[$_ - 1], $prefix . "(" . $_ . ")" . $dot, $arr);
927             }
928            
929             } elsif (ref($data) eq "HASH") {
930 0           for (keys %$data) {
931 0           $out .= _perl2gsc($data->{$_}, $prefix . "." . $_, $arr);
932             }
933            
934             } else {
935 0           croak "Unsupported data structure " .ref $data . "!";
936             }
937            
938 0           return $out;
939             }
940              
941             1;
942              
943             __END__