Главная   Изменения   Спек   Патчи   Исходники   Загрузить   Gear   Bugs and FR  Repocop 

package Alterator::Backend3;
use 5.008008;
use strict;
use warnings;
require Exporter;

our @ISA = qw(Exporter);
our @EXPORT = qw(&{_} &message_loop
             &write_plain &write_begin &write_end
             &write_string_param &write_bool_param &write_num_param &write_debug
             &write_error
             &write_auto_param
             &write_auto_named_list
             &write_enum_item
             test_bool
             $TEXTDOMAIN $DEBUG $LANGUAGE);

our $VERSION    = 0.2;
our $LANGUAGE   ='en_US';  # will be set from language parameter
our $TEXTDOMAIN = undef;   # must be set in backend
our $OUT_BUF    = '';
our $DEBUG      = 0;

sub _{
  my $text = $_[0];
  my $domain = $TEXTDOMAIN;
  $domain = $_[1] if defined $_[1];
  my @lang_list = split(/:/, $LANGUAGE);
  return $text if ($#lang_list<0);
  return `LANGUAGE=\"$LANGUAGE\" LANG=\"$lang_list[0].UTF8\" gettext $domain \"$text\"`;
}

###############

sub string_quote{
  my $ret = join(' ', @_);
  $ret=~s/([\\\"])/\\$1/g;
  return "\"$ret\"";
}

sub bool_quote{
  my $x = lc($_[0]);

  if (($x eq 'yes') ||
      ($x eq 'true') ||
      ($x eq 'on') ||
      ($x eq 'y') ||
      ($x eq '#t') ||
      ($x eq '1')){
    return '#t';
  }
  elsif 
     (($x eq 'no') ||
      ($x eq 'false') ||
      ($x eq 'off') ||
      ($x eq 'n') ||
      ($x eq '#f') ||
      ($x eq '0')){
    return '#f';
  }
  return $_[0];
}

my $NUM_RE = '^([+-]?)(?=\d|\.\d)\d*(\.\d*)?([Ee]([+-]?\d+))?$'; # from perldata(1)  
my $BOOL_RE = '^(#t)|(#f)$';
my $SYM_RE = '(^[0-9A-Za-z_]+$)';

###############

# low-level io

sub real_write{$OUT_BUF.= $_[0];}

sub write_plain{ real_write(join ' ', @_);}

sub write_begin {real_write("(\n");}
sub write_end   {real_write(")\n");}

sub validate_symbol{
  my $symb=$_[0];
  if (!defined($symb) || ($symb !~ /$SYM_RE/)){
    warn "Alterator::Backend3: bad symbol: $symb\n";
    return '__bad_symbol__';
  }
  return $symb;
}

###############

sub write_string_param{
  my $n = validate_symbol(shift);
  my $v = string_quote(@_);
  real_write("$n $v\n");
}

sub write_error{
  $OUT_BUF = '';
  write_string_param('error', @_);
}

sub write_bool_param{
  my $n = validate_symbol(shift);
  my $v = bool_quote(shift);
  if ($v !~ /$BOOL_RE/){
    print STDERR "Alterator::Backend3: bad bool parameter: $n = $v\n, assuming $n = #f";
    $v="#f";
  }
  real_write("$n $v\n");
}

sub write_num_param{
  my $n = validate_symbol(shift);
  my $v = shift;
  if ($v !~ /$NUM_RE/){
    print STDERR "Alterator::Backend3: bad num parameter: $n = $v\n, assuming $n = 0\n";
    $v=0;
  }
  real_write("$n $v\n");
}

sub write_debug{
  print STDERR @_ if ($DEBUG != 0);
}

sub write_enum_item{
  return if !defined($_[0]);
  my $n = string_quote($_[0]);
  my $l = string_quote(defined($_[1])? $_[1]:$_[0]);
  real_write("(name $n label $l)\n");
}


###############

sub write_auto_param{
  my $n = validate_symbol(shift);
  my $v = join(' ', @_);
  if ($v =~ /$BOOL_RE/) {real_write("$n $v\n");}
  else {real_write("$n ".string_quote($v)."\n");}
}

sub write_auto_named_list{
  my $name  = shift;
  real_write("(".string_quote($name)."\n");

  while ($#_ >= 0){
    my $n = shift;
    my $v = shift;
    if (!defined($v)){
      print STDERR "Alterator::Backend3: odd-sized alist!\n";
      $v = '';
    }
    write_auto_param($n, $v);
  }
  real_write(")\n");
}

###############

sub test_bool {
  return $_[0] eq "#t";
}

sub test_sexp{ # TODO!!!
#  my $s = shift;
#  # remove quoted symbols
#  $s =~ s/\\(.)//;
#  my @l = split /\s|\(|\)/, $s;
#  foreach (@l){
#    return 0 unless
#      (/\"[^\"]*\"/) || # string
#      (/$BOOL_RE/)   ||
#      (/$NUM_RE/)    ||
#  }
  return 1;
}


###############

my $pid;

sub message_loop{
    my $handler = shift;

    my $message = {};
    my $reading = undef;

    if (!defined $TEXTDOMAIN){
      my $fname = $0;
      $fname =~s,^.*/,,;
      $TEXTDOMAIN = "alterator-$fname";
      warn "Alterator::Backend3: TEXTDOMAIN variable is undefined! Setting to $TEXTDOMAIN\n";
    }

    open BACKENDOUT,  ">&STDOUT";
    close STDOUT;
    open STDOUT, ">&STDERR";

    my $oldfh = select(BACKENDOUT); $| = 1; select($oldfh);

    while( my $line = <STDIN> ){
      print '>>> ', $line if $DEBUG;
      if( $line eq "_message:begin\n" ) {
        $message = {};
        $reading = 1;
      }
      elsif( $reading && $line eq "_message:end\n" ) {
        if ((defined $message->{language}) && ($message->{language} ne "")){
          $LANGUAGE = $message->{language};
          $LANGUAGE =~ s/;/:/g;
        }
        undef $reading;
        $OUT_BUF='';
        $handler->($message);
        if (!test_sexp($OUT_BUF)){
          warn "Alterator::Backend3: bad response: $OUT_BUF\n";
          print BACKENDOUT '()';
        }
        else {
          print "response >>>(", $OUT_BUF, ")<<<\n" if $DEBUG;
          print BACKENDOUT '(', $OUT_BUF, ')';
        }
      }
      elsif ( $reading ) {
        my ($name, $value) = split /:/ ,$line,2;
        chomp($value);

        $value =~ s/([^\\])\\n/$1\n/g;
        $value =~ s/\\\\/\\/g;
        $message->{$name} = $value;
      }
    }
}

1;

__END__
# Below is stub documentation for your module. You'd better edit it!

=head1 NAME

Alterator::Backend3 - Perl extension for writing backends for Alterator

=head1 SYNOPSIS

  use Alterator::Backend3;

  sub on_message {
      $message = shift;
      write_error( "action:", $message->{action});
  }

  message_loop( \&on_message );

=head1 DESCRIPTION

This module can be used to write backends for ALTLinux Alterator system. 

=head2 EXPORT

None by default.



=head1 SEE ALSO

http://wiki.sisyphus.ru/Alterator/backend3

=head1 AUTHOR

Anton V. Boyarshinov, <lt>boyarah@altlinux.org<gt>
Vladislav V. Zavjalov <lt>slazav@altlinux.org<gt>

=head1 COPYRIGHT AND LICENSE

Copyright (C) 2007 by Anton V. Boyarshinov

This library is free software; you can redistribute it and/or modify
it under the same terms as Perl itself, either Perl version 5.8.8 or,
at your option, any later version of Perl 5 you may have available.


=cut