src/lib/Bcd/Commands/InputCommandParser.pm

   1 package Bcd::Commands::InputCommandParser;
   2
   3 # This file is part of the breadcrumbs daemon (bcd).
   4 # Copyright (C) 2007 Pasqualino Ferrentino
   5
   6 # This program is free software; you can redistribute it and/or modify
   7 # it under the terms of the GNU General Public License as published by
   8 # the Free Software Foundation; either version 2 of the License, or
   9 # (at your option) any later version.
  10
  11 # This program is distributed in the hope that it will be useful, but
  12 # WITHOUT ANY WARRANTY; without even the implied warranty of
  13 # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  14 # GNU General Public License for more details.
  15
  16 # You should have received a copy of the GNU General Public License
  17 # along with this program; if not, write to the Free Software
  18 # Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
  19 # 02110-1301, USA.
  20
  21 # Contact: lino.ferrentino@yahoo.it (in Italian, English or German).
  22
  23 use strict;
  24 use warnings;
  25
  26 use Bcd::Errors::ErrorCodes;
  27 use Data::Dumper;
  28 use MIME::Base64;
  29 use Compress::Zlib;
  30 use Storable qw(thaw);
  31 use Bcd::Data::PostCode;
  32 use POSIX qw(strftime);
  33
  34 use constant PARAM_CHECK_TABLE => {
  35     nick_type                      => \&_check_nick,
  36     post_code_with_sub_or_not_type => \&_check_post_code_with_sub_or_not,
  37     string_type                    => \&_check_string,
  38 };
  39
  40 ##
  41 ##These are the functions which check the validity of the parameter.
  42 sub _check_nick{
  43     my $value = shift;
  44
  45     #the nicks which start with "bc-" are reserved
  46     if ($value =~ /^bc-/){
  47         return Bcd::Errors::ErrorCodes::BEC_RESERVED_ID;
  48     }
  49
  50     if ($value !~ /^[\w-]{3,20}$/){
  51         return Bcd::Errors::ErrorCodes::BEC_LENGTH_OR_CHAR_NOT_VALID_IN_ID;
  52     }
  53
  54     return 0;
  55 }
  56
  57 sub _check_post_code_with_sub_or_not{
  58     my $value = shift;
  59
  60
  61
  62     #let's check the post code. It can be generic, so with or without suffix
  63     if (! Bcd::Data::PostCode::is_valid_post_code_with_sub($value)){
  64         if ( ! Bcd::Data::PostCode::is_valid_post_code($value)){
  65             return Bcd::Errors::ErrorCodes::BEC_INVALID_POST_CODE;
  66         }
  67     }
  68
  69     return 0;
  70 }
  71
  72 sub _check_string{
  73     my $value = shift;
  74
  75     #no controls, for now... maybe length or other... a regex?
  76
  77     return 0;
  78 }
  79
  80
  81 sub new {
  82     my ($class, $mode, $script) = @_;
  83     my $self  = {};
  84
  85     $self->{mode}   = $mode;
  86     $self->{script} = $script;
  87     if ($script == 1){
  88         #ok, I can open the file for scripting
  89         my @time = localtime();
  90         my $year = $time[5] + 1900;
  91         my $month = $time[4] + 1;
  92         my $name = "/tmp/${year}_${month}_$time[3]_$time[2]_$time[1]_$time[0]_bc_script";
  93         my $file;
  94         open $file, "> $name" or die "cannot open file $name";
  95         $self->{script_file} = $file;
  96     }
  97
  98     bless ($self, $class);
  99     return $self;
 100 }
 101
 102 sub end_of_input{
 103     my $self = shift;
 104     if ($self->{script} == 1){
 105         close $self->{script_file};
 106     }
 107 }
 108
 109 sub select_mode{
 110     my ($self, $mode) = @_;
 111     $self->{mode} = $mode;
 112 }
 113
 114 sub start_parsing_command {
 115     my ($self, $param_table) = @_;
 116
 117     $self->{param_table}   = $param_table;
 118     $self->{parsing_result}= Bcd::Errors::ErrorCodes::BEC_OK;
 119     $self->{parsing_index} = 0;
 120     #$self->{err_flag}      = 0;
 121     $self->{parsed_result} = {};
 122     $self->{_args} = [];
 123
 124 }
 125
 126 #this method selects a particular input stream from which
 127 #we can extract the parameters.
 128 sub new_command_from_input{
 129     my ($self, $command, $input_stream) = @_;
 130     if ($self->{script} == 1){
 131         #ok, I write the command name in the file
 132         $self->{script_file}->flush() if ($command eq "an_get_summary");
 133         my $now_string = strftime "%a %b %e %H:%M:%S %Y", localtime;
 134         my $file = $self->{script_file};
 135         print $file "\n#### new command at $now_string\n";
 136         print $file $command . "\n";
 137     }
 138     $self->{_input} = $input_stream;
 139 }
 140
 141 sub select_command{
 142     my ($self, $command) = @_;
 143     $self->{_command} = $command;
 144 }
 145
 146 sub _validate_params{
 147     my $self = shift;
 148
 149     $self->{parsing_result} = Bcd::Errors::ErrorCodes::BEC_OK;
 150
 151     my $param_list = $self->{param_table}->[0];
 152     my $param_hash = $self->{param_table}->[1];
 153     foreach(@{$param_list}){
 154         if ($self->_validate_param($param_hash->{$_}, $self->{parsed_result}->{$_})){
 155             return 1;
 156         }
 157     }
 158
 159     return 0;
 160 }
 161
 162 sub _validate_param{
 163     my ($self, $param_desc, $param_value) = @_;
 164
 165     #first of all I check the existence of the parameter
 166     if (!defined($param_value)){
 167         if ($param_desc->[1] eq "required"){
 168             $self->{parsing_result} = Bcd::Errors::ErrorCodes::BEC_REQUIRED_PARAMETER_MISSING;
 169             return 1; #this parameter is required
 170         } else {
 171             return 0;
 172         }
 173     }
 174
 175     #ok, the parameter has a value, let's check it
 176     my $param_type = $param_desc->[0];
 177
 178     if (!exists(PARAM_CHECK_TABLE->{$param_type})){
 179         die "unknown parameter type $param_type";
 180     } else {
 181         my $res;
 182         if ($res = &PARAM_CHECK_TABLE->{$param_type}($param_value)){
 183             if ($res != 0){
 184                 $self->{parsing_result} = $res;
 185                 return 1;
 186             }
 187         }
 188     }
 189
 190     #ok all is ok
 191     return 0;
 192 }
 193
 194 sub parse_binary_input{
 195     my $self    = shift;
 196     my $command = $self->{_command};
 197     my $input   = $self->{_input};
 198
 199     my $stream_mode = <$input>;
 200     my $compressed = 0;
 201
 202     if ($stream_mode =~ /c/){
 203         $compressed = 1;
 204     }
 205
 206     my $blob = "";
 207     while(<$input>){
 208         chomp;
 209         if ($_ eq "."){
 210             last;
 211         }
 212         #the dot at the start of the string should be avoided
 213         s/^\.(.*)$/$1/sg;
 214
 215         $blob .= $_;
 216     }
 217
 218     #ok, I have the blob
 219     my $decoded = decode_base64($blob);
 220
 221     my $stream;
 222     if ($compressed == 1){
 223         #ok, I should decompress it!
 224         $stream = Compress::Zlib::memGunzip($decoded);
 225     } else {
 226         $stream = $decoded;
 227     }
 228
 229     my $res = thaw $stream;
 230
 231     #ok, now I make the script, if it is needed
 232     if ($self->{script} == 1){
 233         if (ref $res eq "ARRAY"){
 234             #Ok, I make a cycle
 235             foreach(@{$res}){
 236                 my $tmp = $_;
 237                 $tmp =~ s/^(\.?)/$1$1/sg;
 238                 $tmp =~ s/\012(\.?)/\012$1$1/sg;
 239                 $tmp =~ s/\012(.)/\\\012$1/sg;
 240                 print {$self->{script_file}} $tmp . "\n";
 241             }
 242             #at the end a print a single dot
 243             print {$self->{script_file}} ".\n#END OF COMMAND\n";
 244         }
 245     }
 246
 247     #ok, I have the input...
 248     my $param_list;
 249     if (defined($command)){
 250         $self->_inject_the_old_parameters($res);
 251     } else {
 252         $self->fill_params($self->{param_table}, $res);
 253     }
 254 }
 255
 256 #this is a function used only to inject the parameters in the old commands
 257 sub _inject_the_old_parameters{
 258     my ($self, $params) = @_;
 259
 260     my $command = $self->{_command};
 261
 262     my $param_list = $command->{parameters};
 263
 264     my $i = 0;
 265     #if I have the command I inject the parameters
 266     #inside the command, this is a hack for the legacy commands
 267     my $ellipsis = 0;
 268     foreach(@{$params}){
 269         my $param = $param_list->[$i];
 270         my $name;
 271         if (ref($param) eq "HASH"){
 272             if ($param->{type} eq "multi_line"){
 273                 $name = $param->{name};
 274             } elsif ($param->{type} eq "ellipsis"){
 275                 $ellipsis = 1;
 276                 #ok... I should inject the ellipsis
 277                 if (! exists($command->{ellipsis})){
 278                     $command->{ellipsis} = []; #empty array
 279                 }
 280                 push(@{$command->{ellipsis}}, $_);
 281                 #print Dumper($command->{ellipsis});
 282                 next; #I do not advance in the counter...
 283             }
 284         } else {
 285             $name = $param_list->[$i];
 286         }
 287
 288         $command->{$name} = $_;
 289         $i++;
 290     }
 291
 292     #ok, now I should check the number of parameters
 293     if ($ellipsis == 0){
 294         #no ellipsis, the number of parameters should be the same
 295         if (scalar(@{$params}) > scalar(@{$param_list})){
 296             $self->{parsing_result} = Bcd::Errors::ErrorCodes::BEC_TOO_MANY_PARAMETERS;
 297         } elsif (scalar(@{$params}) < scalar(@{$param_list})){
 298             $self->{parsing_result} = Bcd::Errors::ErrorCodes::BEC_TOO_FEW_PARAMETERS;
 299         }
 300     } else {
 301         #there is an ellipsis, the number of parameters should be greater
 302         if (scalar(@{$params}) < scalar(@{$param_list})){
 303             $self->{parsing_result} = Bcd::Errors::ErrorCodes::BEC_TOO_FEW_PARAMETERS;
 304         }
 305     }
 306
 307     #I force the ok
 308     $command->{state} = Bcd::Commands::SimpleCommand::READY_TO_EXECUTE;
 309 }
 310
 311 #this is a recursive function, I fill the params in the tables walking the tree
 312 #of the descendants
 313 sub fill_params{
 314     my ($self, $param_table, $params) = @_;
 315
 316     my $children = $param_table->[2];
 317
 318     if (defined($children)) {
 319         #recurse inside the children
 320         foreach(@{$children}){
 321             $self->fill_params($_, $params);
 322         }
 323     }
 324
 325     #ok, then I fill this part of the table and return one level up
 326     my $list = $param_table->[0];
 327     foreach(@{$list}){
 328         $self->{parsed_result}->{$_} = shift(@{$params}); #they are in order
 329     }
 330
 331 }
 332
 333 sub parse_input{
 334     my $self = shift;
 335
 336     my $command = $self->{_command};
 337     my $input   = $self->{_input};
 338
 339     $command->start_parsing_command() if (defined($command));
 340
 341     if ($self->{mode} == Bcd::Common::CommonConstants::BINARY_MODE){
 342         $self->parse_binary_input();
 343         $self->eot() if (!defined($command));
 344     } else {
 345
 346         my @input_params;
 347         my $multi_line = 0;
 348         my $back_line  = "";
 349
 350         while (<$input>){
 351
 352             chomp;
 353
 354             if ($_ eq "."){
 355                 last;
 356             }
 357
 358             s/^\.(.+)/$1/sg;
 359             s/\\\\$/\\/sg;
 360
 361             #now the slash part
 362             #if it has remained a single slash before the end simply continues on the same line
 363             if (/\\$/){
 364                 chop; #eliminate the single slash...
 365                 if ($multi_line == 0){
 366                     $back_line = $_;
 367                     $multi_line = 1;
 368                 } else {
 369                     $back_line .= "\n";
 370                     $back_line .= $_;
 371                 }
 372                 next;
 373             }
 374
 375             my $cur_line;
 376
 377             if ($multi_line == 1){
 378                 $back_line .= "\n";
 379                 $back_line .= $_;
 380                 #I return normally for the next part
 381                 $multi_line = 0;
 382                 $cur_line = $back_line;
 383             } else {
 384                 $cur_line = $_;
 385             }
 386
 387             #if (defined($command)){
 388                 #$command->parse_line($cur_line);
 389             #} else {
 390             push(@input_params, $cur_line);
 391             #}
 392
 393         }
 394
 395         if (defined($command)){
 396             $self->_inject_the_old_parameters(\@input_params);
 397         } else {
 398             $self->fill_params($self->{param_table}, \@input_params);
 399             $self->eot();
 400
 401         }
 402     }
 403 }
 404
 405 sub eot{
 406     my $self = shift;
 407
 408 #     if ($self->{parsing_index} < scalar(@{$self->{param_table}->[0]})){
 409 #       $self->{parsing_result} = Bcd::Errors::ErrorCodes::BEC_TOO_FEW_PARAMETERS;
 410 #     }
 411
 412     #ok, I have all the parameters... let's validate them
 413     $self->_validate_params();
 414 }
 415
 416 #this is called for the tests
 417 sub eot_from_test{
 418     my $self = shift;
 419
 420     #I have to fill the parameters
 421     $self->fill_params($self->{param_table}, $self->{_args});
 422     $self->_validate_params();
 423
 424     #print "eot_from_test\n";
 425     #print Dumper($self);
 426     #print "eot_from_test end \n";
 427 }
 428
 429 sub parse_line{
 430     my ($self, $line) = @_;
 431
 432 #     if ($self->{err_flag} != 0){
 433 #       #out of sync...
 434 #       return;
 435 #     }
 436
 437 #     if ($self->{parsing_index} >= scalar(@{$self->{param_table}->[0]})){
 438 #       #too many parameters...
 439 #       $self->{err_flag} = 1;
 440 #       $self->{parsing_result} = Bcd::Errors::ErrorCodes::BEC_TOO_MANY_PARAMETERS;
 441 #       return;
 442 #     } else {
 443 #       #check the validity of the parameter... ?
 444 #       $self->{parsed_result}->{$self->{param_table}->[0]->[$self->{parsing_index}]} =
 445 #           $line;
 446 #       $self->{parsing_index} ++;
 447 #       return;
 448 #     }
 449
 450     push(@{$self->{_args}}, $line);
 451 }
 452
 453 sub parse_input_blob{
 454 }
 455
 456 sub get_parsing_result{
 457     my $self = shift;
 458     return $self->{parsing_result};
 459 }
 460
 461 sub get_parsed_result{
 462     my $self = shift;
 463     return $self->{parsed_result};
 464 }
 465
 466 #an alias
 467 sub get_input{
 468     my $self = shift;
 469     return $self->{parsed_result};
 470 }
 471
 472 1;