[Tinyos-commits] CVS: tinyos-1.x/tos/lib/VM/languages/tinysql/src .cvsignore, NONE, 1.1 Makefile.am, NONE, 1.1 lex.mll, NONE, 1.1 parse.mly, NONE, 1.1 sql.mli, NONE, 1.1 sqlgen.ml, NONE, 1.1 tinysql.in, NONE, 1.1

[David Gay]

Update of /cvsroot/tinyos/tinyos-1.x/tos/lib/VM/languages/tinysql/src
In directory sc8-pr-cvs1.sourceforge.net:/tmp/cvs-serv20471/languages/tinysql/src

Added Files:
	.cvsignore Makefile.am lex.mll parse.mly sql.mli sqlgen.ml 
	tinysql.in 
Log Message:
-I option for finding tinysql attributes, aggregates
reorganise tinysql directory
misc doc updates


--- NEW FILE: .cvsignore ---
Makefile
Makefile.in
*.cm*
lex.ml
parse.mli
parse.ml
tinysql
tinysqlcc
.deps

--- NEW FILE: Makefile.am ---
AUTOMAKE_OPTIONS = foreign

bin_PROGRAMS = tinysqlcc$(EXEEXT)

bin_SCRIPTS = tinysql

tinysqlcc$(EXEEXT): lex.mll parse.mly sql.mli sqlgen.ml
	ocamlyacc parse.mly
	ocamllex lex.mll
	ocamlc -o $@ sql.mli parse.mli parse.ml lex.ml sqlgen.ml

--- NEW FILE: lex.mll ---
{
open Parse
open Sql
exception Eof
let lastpos = ref Lexing.dummy_pos
let lasttoken = ref ""
let savepos lb = 
  lastpos := Lexing.lexeme_start_p lb;
  lasttoken := Lexing.lexeme lb  
}
rule token = parse
    [' ' '\t' '\n']     { token lexbuf }     (* skip blanks *)
  | ['0'-'9']+ as lxm { savepos lexbuf; INT (int_of_string lxm) }
  | "select"	   { savepos lexbuf; SELECT }
  | "where"	   { savepos lexbuf; WHERE }
  | "interval"	   { savepos lexbuf; INTERVAL }
  | "sample"' '+"period" { savepos lexbuf; INTERVAL }
  | ','		   { savepos lexbuf; SCOMMA }
  | '<'		   { savepos lexbuf; SLT }
  | "<="	   { savepos lexbuf; SLE }
  | '>'		   { savepos lexbuf; SGT }
  | ">="	   { savepos lexbuf; SGE }
  | '='		   { savepos lexbuf; SEQ }
  | "<>"	   { savepos lexbuf; SNE }
  | "and"	   { savepos lexbuf; SAND }
  | "or"	   { savepos lexbuf; SOR }
  | "not"	   { savepos lexbuf; SNOT }
  | '('		   { savepos lexbuf; OPAREN }
  | ')'		   { savepos lexbuf; CPAREN }
  | '['		   { savepos lexbuf; OPAREN2 }
  | ']'		   { savepos lexbuf; CPAREN2 }
  | ['A'-'Z' 'a'-'z']['A'-'Z' 'a'-'z' '0'-'9']* as id { savepos lexbuf; ID id }
  | eof            { raise Eof }

--- NEW FILE: parse.mly ---
%{
open Sql
let newopname = 
  let count = ref 0
    in function () -> count := !count + 1; "op" ^ string_of_int !count
%}

%token <int> INT
%token <string> ID
%token SELECT WHERE INTERVAL
%token SCOMMA SAND SOR SNOT SLT SLE SGT SGE SEQ SNE OPAREN CPAREN OPAREN2 CPAREN2
%type <Sql.query> main
%type <Sql.value list> fields gfields
%type <Sql.value> field value
%type <Sql.condition option> condition_opt
%type <Sql.condition> condition condition1 condition2 condition3
%type <Sql.relop> relop
%type <Sql.value list> vlist

%left SOR
%left SAND
%nonassoc SNOT

%start main

%%

main:
	SELECT fields condition_opt INTERVAL INT 
	  { { fields = List.rev $2; cond = $3; interval = $5; global = false } }
      | SELECT gfields condition_opt INTERVAL INT 
	  { { fields = List.rev $2; cond = $3; interval = $5; global = true } }
      ;

fields:
	fields SCOMMA field { $3::$1 }
      | field { [$1] }
      ;

gfields:
	gfields SCOMMA gfield { $3::$1 }
      | gfield { [$1] }
      ;

field: value { $1 } ;

gfield: ID OPAREN2 vlist CPAREN2 { GOp ($1, List.rev $3, newopname()) } ;


condition_opt:
	WHERE condition { Some $2 }
      | /* empty */     { None }
      ;

condition: 
        condition SOR condition { Bool (OR, $1, $3) }
      | condition1 { $1 }
      ;

condition1: 
	condition1 SAND condition1 { Bool (AND, $1, $3) }
      | condition2 { $1 }
      ;

condition2: 
	SNOT condition2 { Not $2 }
      | condition3 { $1 }
      ;

condition3: 
	value relop value { Rel ($2, $1, $3) }
      | OPAREN condition CPAREN { $2 }
      ;

value: 
	ID { Attribute $1 }
      | INT { Number $1 }
      | ID OPAREN vlist CPAREN { Op ($1, List.rev $3, newopname()) }
      ;

vlist:
	value { [$1] }
      | vlist SCOMMA value { $3::$1 }
      ;

relop: SLT { LT } | SLE { LE } | SGT { GT } | SGE { GE } | SEQ { EQ } | SNE { NE } ;

--- NEW FILE: sql.mli ---
type 
  value = Attribute of string | 
  	  Number of int |
	  Op of (string * value list * string) |
	  GOp of (string * value list * string)
and
  relop = LT | LE | GT | GE | EQ | NE
and
  boolop = AND | OR
and
  condition = Rel of relop * value * value | 
	      Bool of boolop * condition * condition |
	      Not of condition
and
  query = { fields: value list; cond: condition option; interval: int; 
	    global: bool }
and
  genexpr = { init: string option; update: string; get: string;
              intercept: int -> string; size: string; newepoch: string }

--- NEW FILE: sqlgen.ml ---
open Sql
open List
open String
open Char
open Printf
open Hashtbl

let optionfn none some = function
   None -> none
 | Some c -> some c

let present = function
    None -> false
  | Some _ -> true

let indent n = make n ' '

let relname = function
   LT -> "<"
 | LE -> "<="
 | GT -> ">"
 | GE -> ">="
 | EQ -> "=="
 | NE -> "!="

let boolname = function
   AND -> "&&"
 | OR -> "||"

let rec valprint = function 
   Attribute s -> s
 | Number n -> string_of_int n
 | Op (name, args, _) -> sprintf "%s(%s)" name (concat ", " (map valprint args))
 | GOp (name, args, _) -> sprintf "%s[%s]" name (concat ", " (map valprint args))


let rec cprint = function
   Rel (op, v1, v2) -> sprintf "(%s %s %s)" (valprint v1) (relname op) (valprint v2)
 | Bool (op, c1, c2) -> sprintf "(%s %s %s)" (cprint c1) (boolname op) (cprint c2)
 | Not c -> sprintf "!%s" (cprint c)

let condprint = optionfn "" (function c -> " WHERE " ^ cprint c)

let schemaprint schemanames = 
  let rec schemaname basename = 
    if (Hashtbl.mem schemanames basename) then
      let next = Hashtbl.find schemanames basename in
        Hashtbl.replace schemanames basename (next + 1);
        sprintf "%s%d" basename next
    else
      begin
        Hashtbl.replace schemanames basename 1;
        basename
      end
  and sprint = function 
      Attribute s -> s
    | Number n -> "number"
    | Op (name, args, _) -> sprintf "%s_%s" name (sprint (hd args))
    | GOp (name, args, _) -> sprintf "%s_%s" name (sprint (hd args))
  in
    function s -> schemaname (sprint s)


let sqlprint { fields = f; cond = c; interval = i } =
  printf "// SELECT %s%s INTERVAL %d\n" 
    (concat ", " (map valprint f)) 
    (condprint c) i;
  let schemanames = Hashtbl.create 16  in
    printf "// SCHEMA: %s\n"
      (concat " " (map (schemaprint schemanames) f))

let sqlheader interval global vars msgvars allvars = 
  printf "mhop_set_update(%d); settimer0(%d);\n" 
    (interval * 2) (interval * 10);
  List.iter (function v -> match (find vars v) with
     { init = None } -> ()
   | { init = Some create } -> printf "%s;\n" create)
     (if global then allvars @ msgvars else allvars);
  if global then begin
    printf "mhop_set_forwarding(0);\n";
    printf "
any snoop() snoop_epoch(decode(snoop_msg(), vector(2))[0]);
any intercept() 
  {
    vector fields = decode(intercept_msg(), vector(%s));

    snoop_epoch(fields[0]);
"
      (let fieldsizes = map (function f -> (find vars f).size) msgvars
       in (concat ", " ("2" :: fieldsizes)));

    let evil = ref 1 in
      let genintercept s = 
        let index = !evil in
          begin
            evil := index + 1;
	    s index
	  end
      in
        List.iter (function f -> printf "    %s;\n" 
                                   (genintercept ((find vars f).intercept)))
	          msgvars;
    printf "  }\n";
    printf "any epochchange()\n  {\n";
    List.iter (function f -> printf "    %s;\n" ((find vars f).newepoch))
	      msgvars;
    printf "  }\n"
  end else begin
    (* non-global case *)
    printf "mhop_set_forwarding(1);\n";
    print_string "
any snoop() heard(snoop_msg());
any intercept() heard(intercept_msg());
any heard(msg) snoop_epoch(decode(msg, vector(2))[0]);
";
  print_string "\n";
  end

let valuse = function 
   Attribute s -> "v_" ^ s
 | Number n -> string_of_int n
 | Op (_, _, gen) -> "v_" ^ gen
 | GOp (_, _, gen) -> "v_" ^ gen

let valvars = function 
   Attribute s -> [s]
 | Number n -> []
 | Op (_, _, gen) -> [gen]
 | GOp (_, _, gen) -> [gen]

let make_genlocal init get = { init = init; get = get; size = "2"; update = ""; newepoch = ""; intercept = function n -> "" }

let valattrs vars ops = 
  let rec vattrs = function
     Attribute s -> 
	Hashtbl.replace ops s ();        
        if mem vars s then [] 
	else (let attrget = s ^ "()" in
	  add vars s (make_genlocal None attrget);
	  [s])
   | Op (name, args, gen) ->
	Hashtbl.replace ops name ();        
        let vargs = flatten (map vattrs args) 
	and (cst, noncst) =
	   partition (function Number _ -> true | _ -> false) args
	and statename = "s_" ^ gen
	in let getargs = (concat ", " (statename :: (map valuse noncst)))
	   and makeargs = (concat ", " (map valuse cst)) in
	     add vars gen (make_genlocal
			     (Some (sprintf "any %s = %s_make(%s)" statename
							      name
							      makeargs))
			     (sprintf "%s_get(%s)" name getargs));
             vargs @ [gen]
   | GOp (name, args, gen) ->
	Hashtbl.replace ops name ();        
        let vargs = flatten (map vattrs args) 
	and (cst, noncst) =
	   partition (function Number _ -> true | _ -> false) args
	and statename = "s_" ^ gen
	in let getargs = (concat ", " (statename :: (map valuse noncst)))
	   and makeargs = (concat ", " (map valuse cst)) in
          let code = { init = Some (sprintf "any %s = %s_make(%s)" statename
							      name
							      makeargs);
		      get = sprintf "%s_get(%s)" name statename;
		      size = name ^ "_buffer()";
		      update = sprintf "%s_update(%s)" name getargs;
		      intercept = sprintf "%s_intercept(%s, fields[%d])" name statename;
		      newepoch = sprintf "%s_newepoch(%s)" name statename } in
	     add vars gen code;
             vargs
   | _ -> []
  in vattrs

let cattrs vars ops =
  let rec cf = function
     Rel (_, v1, v2) -> (valattrs vars ops v1) @ (valattrs vars ops v2)
   | Bool (_, c1, c2) -> (cf c1) @ (cf c2)
   | Not c -> cf c
  in cf

let condattrs vars ops = optionfn [] (cattrs vars ops)

let rec cc = function
   Rel (op, v1, v2) -> sprintf "(%s %s %s)" (valuse v1) (relname op) (valuse v2)
 | Bool (op, c1, c2) -> sprintf "(%s %s %s)" (cc c1) (boolname op) (cc c2)
 | Not c -> sprintf "!%s" (cc c)

let condcompile afterif = optionfn "" 
   (function cond -> sprintf "if (%s)%s" (cc cond) afterif)

let getprint ind vars vlist =
  let prefix = indent ind in
  List.iter (function v -> let { get = g } = find vars v in 
	                      printf "%sany v_%s = %s;\n" prefix v g)
	    vlist

let print_update ind vars msgvars =
  let prefix = indent ind in
  List.iter (function v -> printf "%s%s;\n" prefix ((find vars v).update)) msgvars

let sqlsend fields cond global vars msgvars allvars =
  printf "any Timer0()\n{\n";
  printf "  led(l_blink | l_green);\n";
  if global then
    begin
      print_string "  if (id()) {\n";
      getprint 4 vars allvars;
      print_string "\n    next_epoch();\n";
      if present cond then
        begin
          printf "    %s" (condcompile " {\n" cond);
	  print_update 6 vars msgvars;
          print_string "    }\n"
	end
      else
	print_update 4 vars msgvars;
      print_string "  }\n";
      print_string "  {\n";
      getprint 4 vars msgvars;
      print_string "\n    ";
    end
  else 
    begin
      print_string "  if (id()) {\n";
      getprint 4 vars allvars;
      print_string "\n    next_epoch();\n";
      printf "    %s" (condcompile "\n      " cond);
    end;
  printf "mhopsend(encode(vector(epoch(), %s)));\n" 
    (concat ", " (map valuse fields));
  print_string "  }\n";
  print_string "}\n"

let loadcode opname = 
  let rec trydir i =
    if i >= Array.length Sys.argv then
      ()
    else
      try
        let rec fd = open_in (Sys.argv.(i) ^ opname ^ ".mt") 
        and dumpfd f = 
          try
            printf "%s\n" (input_line f);
	    dumpfd f
          with End_of_file -> ()
        in
          dumpfd fd;
          close_in_noerr fd
      with Sys_error n -> trydir (i + 1)
  in trydir 1

let sqlimport ops = 
    Hashtbl.iter (function op -> function _ -> printf "// uses %s\n" op;
		  loadcode op) ops

let sqlgen { fields = f; cond = c; interval = i; global = g } =
  let vars = Hashtbl.create 16 
  and ops = Hashtbl.create 16 in
    let fvars = flatten (map (valattrs vars ops) f)
    and msgvars = flatten (map valvars f) 
    and cvars = condattrs vars ops c in
      let allvars = fvars @ cvars in
        sqlimport ops;
        sqlheader i g vars msgvars allvars;
	sqlsend f c g vars msgvars allvars

let lowercase_stdin s n =
  let count = input stdin s 0 n in
    begin 
      for i = 0 to count - 1 do
        s.[i] <- lowercase (s.[i])
      done
    end;
    count

let print_error () = 
  let error_column = (!Lex.lastpos).Lexing.pos_cnum + 1 in
    if String.length !Lex.lasttoken > 0 then
      eprintf "syntax error near \"%s\" (column %d)\n" !Lex.lasttoken error_column
    else
      eprintf "syntax error near column %d\n" error_column;
    exit 2


let _ = 
  try
    let lexbuf = Lexing.from_function lowercase_stdin in
      let result = Parse.main Lex.token lexbuf in
        sqlprint result;
        sqlgen result
  with x ->
    print_error ()

--- NEW FILE: tinysql.in ---
#!@pathperl@

use Socket;

$BROADCAST = 0xffff;

add_incdir(".");

for ($i = 0; $i <= $#ARGV; $i++) {
    $_ = $ARGV[$i];
    if (/^-/) {
	if (/^-h$/ || /^--help$/) {
	    usage();
	}
	elsif (/^-I$/ && $i < $#ARGV) {
	    add_incdir($ARGV[++$i]);
	}
	elsif (/^-I(.+)$/) {
	    add_incdir($1);
	}
	else {
	    usage();
	}
    }
    else {
	if (!defined($action)) {
	    $action = $_;
	}
	elsif (!defined($query)) {
	    $query = $_;
	}
	else {
	    usage();
	}
    }
}

usage() unless $action;

$tosdir=`ncc -print-tosdir`;
$tosdir =~ s/(\n|\r)//g;
add_incdir("$tosdir/lib/VM/languages/tinysql/lib");
$tsqlcc = "tinysqlcc " . join(" ", @incdirs);

$tmpf = "/tmp/tinysql.$$";
$qfile = "$ENV{HOME}/.tinysql_query";

sub END {
    unlink $tmpf;
}

if ($action eq "start") {
    $install = 1;
    $mote_install = 1;
    $log = 1; 
}
elsif ($action eq "log") {
    $display = 1;
    $log = 1;
}
elsif ($action eq "compile") {
    $compile = 1;
}
elsif ($action eq "install") {
    $install = 1;
    $mote_install = 1;
}
elsif ($action eq "reinstall") {
    $mote_install = 1;
    $display = 1;
}
elsif ($action eq "display") {
    $display = 1;
}
elsif ($action eq "stop") {
    $stop = 1;
}
else {
    usage();
}

if ($compile) {
    exit 2 if system("echo \"$query\" | $tsqlcc > $tmpf");
    system("cat $tmpf");
    exit 2 if system("motlle-load -c $tmpf");
}

if ($install) {
    exit 2 if system("echo \"$query\" | $tsqlcc > $qfile");
}

if ($display) {
    $query = current_query();
    print "#QUERY: $query\n" if $query;
    print "No active query\n" if !$query;
}

if ($mote_install) {
    if (-f $qfile) {
	exit 2 if system("motlle-load $qfile");
    }
    else {
	exit 2;
    }
}

if ($log) {
    $schema = current_schema();
    print "#SCHEMA: $schema\n";
    exit 1 if !$schema;
    tsqllog($schema);
}

if ($stop) {
    unlink $qfile;
    exit 2 if system("motlle-load -e \"led(0)\"");
}

exit 0;

sub usage {
    print <<EOF
Usage: tinysql [-I dir1 -I dir2...] COMMAND QUERY
where COMMAND is one of:
  start        install QUERY followed by log
  install      install QUERY in the sensor network
  reinstall    reinstall current query in the sensor network
  log          display continuous results from current query
  stop         stop current query in sensor network
  display      display current query
  compile      just compile QUERY and print resulting motlle code

  QUERY is a TinySQL query (not needed for reinstall, log, stop, display)

  The -I directives specify directories in which user-defined aggregates
  and attributes can be found.

  start, install, reinstall, log and stop require that a serial forwarder,
  talking to TinySQL mote 0 be running on the local host.

  Examples:
    tinysql start "select id, light interval 10"
    tinysql compile "oops"
    tinysql stop
EOF
;
    exit 0;
}

sub add_incdir {
    my ($dir) = @_;

    $dir .= "/" unless $dir =~ m!/$!;
    push @incdirs, "\"$dir\"";
}

sub current_query {
    my $query;

    open QUERY, $qfile or return undef;
    while (<QUERY>) {
	$query = $1 if m!^// (SELECT .*)!;
    }
    close QUERY;
    return $query;
}

sub current_schema {
    my $schema;

    open QUERY, $qfile or return undef;
    while (<QUERY>) {
	$schema = $1 if m!^// SCHEMA: (.*)!;
    }
    close QUERY;
    return $schema;
}

sub tsqllog {
    my ($schema) = @_;
    my @schema = split / /, $schema;

    sf_connect(BASE, "localhost", 9001);
    for (;;) {
	my $packet = sf_recv(BASE, undef);
	my ($dest, $amid, $group, $length, $msg) = unpack_message $packet;
	my $offset;

	if ($amid == 0x2b || $amid == 0x2c) {
	    $offset = 12;
	}
	elsif ($amid == 0x2a) {
	    $offset = 5;
	}
	else {
	    next;
	}
	if (2 * ($#schema + 1) != $length - $offset) {
	    print "#invalid packet\n";
	    next;
	}
	my @fields = unpack ("v" x ($#schema + 1), substr $msg, $offset);
	print join(" ", @fields);
	print "\n";
    }
    close(BASE);
}

# Build a TOSMsg in a perl string
sub message {
    my ($dest, $amid, @data) = @_;
    my ($msg);

    return pack "vCCCC*", $dest, $amid, 0, $#data + 1, @data;
}

sub unpack_message {
    my ($msg) = @_;

    return unpack "vCCCC*", $msg;
}

sub print_message {
    my ($msg) = @_;

    for ($i = 0; $i < length $msg; $i++) {
	printf "%02x ", ord(substr($msg, $i, 1));
    }
}
    

# Connect to a serial forwarder
sub sf_connect {
    my ($handle, $host, $port) = @_;
    my ($lhost, $ptcp);

    $lhost = inet_aton($host) || die "can't lookup $host";
    $ptcp = getprotobyname("tcp");
    socket($handle, PF_INET, SOCK_STREAM, $ptcp) || die "SF socket";
    connect($handle, sockaddr_in($port, $lhost)) || die "No serial forwarder at $host:$port";
    # Send identifying string ('T', ' ' for original version)
    sf_write($handle, "T ");
    $s = sf_read($handle, 2);
    die "Not a serial forwarder at $host:$port" unless
	substr($s, 0, 1) eq "T" && ord(substr($s, 1)) >= 32;
}

# Write a string to a handle, abort on error
sub sf_write {
    my ($handle, $string) = @_;

    while ($string ne "") {
	$cnt = syswrite($handle, $string);
	if (!$cnt) {
	    print "write error $! $cnt\n";
	    exit 2;
	}
	$string = substr($string, $cnt);
    }
}

# Read n bytes from a handle, abort on error and timeout
sub sf_read {
    my ($handle, $n, $timeout) = @_;
    my ($s, $offset, $rin);

    $offset = 0;
    vec($rin, fileno($handle), 1) = 1;
    while ($offset < $n) {
	$cnt = select($rin, undef, undef, $timeout);
	if (!$cnt) {
	    print "read error: timeout\n";
	    exit 2;
	}
	$cnt = sysread $handle, $s, $n, $offset;
	if (!$cnt) {
	    print "read error $cnt $!\n";
	    exit 2;
	}
	$offset += $cnt;
    }
    return $s;
}

# Send a packet to a serial forwarder
sub sf_send {
    my ($handle, $msg) = @_;

    $msg = chr(length $msg) . $msg;
    sf_write($handle, $msg);
}

# Receive a packet from a serial forwarder
sub sf_recv {
    my ($handle, $timeout) = @_;
    my ($s);

    $len = ord(sf_read($handle, 1, $timeout));
    $s = sf_read($handle, $len, $timeout);

    # Set group id to 0 to simplify life
    substr($s, 3, 1) = chr(0);

    return $s;
}