/pliant/admin/execute.pli
 
 1  # Copyright  Hubert Tonneau  hubert.tonneau@pliant.cx 
 2  # 
 3  # This program is free software; you can redistribute it and/or 
 4  # modify it under the terms of the GNU General Public License version 2 
 5  # as published by the Free Software Foundation. 
 6  # 
 7  # This program is distributed in the hope that it will be useful, 
 8  # but WITHOUT ANY WARRANTY; without even the implied warranty of 
 9  # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the 
 10  # GNU General Public License for more details. 
 11  # 
 12  # You should have received a copy of the GNU General Public License 
 13  # version 2 along with this program; if not, write to the Free Software 
 14  # Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA. 
 15   
 16  module "/pliant/language/compiler.pli" 
 17  module "/pliant/language/os.pli" 
 18  module "/pliant/language/stream.pli" 
 19  module "/pliant/language/stream/handle.pli" 
 20  module "/pliant/admin/file.pli" 
 21   
 22   
 23  if os_api="linux" 
 24    module "/pliant/language/schedule/threads_engine.pli" 
 25   
 26    function close_handles 
 27      var Int maxi := stream_maximum_handle+stream_pending_handles+5 
 28      for (var Int h) maxi 
 29        os_close h 
 30   
 31    gcc_off 
 32   
 33      function execute1 cmd path root user group input output err envptr detached id -> retcode 
 34        arg Str cmd path root ; arg Int user group input output err ; arg Address envptr ; arg CBool detached ; arg_rw Int id ; arg Int retcode 
 35        var Address args := (memory_allocate 8*Address:size+(cmd:len+1)*Address:size null) translate Address 8 
 36        var Int nb := 0 
 37        var Int base := 0 
 38        var Char stop := " " 
 39        for (var Int i) cmd:len 
 40          if i=cmd:len or cmd:i=stop 
 41            if i>base or stop="'" 
 42              var Pointer:Address arg :> (args translate Address nb) map Address 
 43              arg := memory_allocate i-base+args 
 44              for (var Int j) base i-1 
 45                (arg translate Byte j-base) map uInt8 := cmd:j:number 
 46              (arg translate Byte i-base) map uInt8 := 0 
 47              nb := nb+1 
 48              stop := " " 
 49            base := i+1 
 50          eif i=base and cmd:i="'" and stop=" " 
 51            base := i+1 
 52            stop := "'" 
 53        var Address pathz 
 54        if path<>"" 
 55          pathz := memory_allocate path:len+1 null 
 56          memory_copy path:characters pathz path:len 
 57          (pathz translate Byte path:len) map uInt8 := 0 
 58        else 
 59          pathz := null 
 60        var Address rootz 
 61        if root<>"" 
 62          rootz := memory_allocate root:len+1 null 
 63          memory_copy root:characters rootz root:len 
 64          (rootz translate Byte root:len) map uInt8 := 0 
 65        else 
 66          rootz := null 
 67        (args translate Address -1) map Address := pathz 
 68        (args translate Address -2) map Address := rootz 
 69        (args translate Address -3) map Int := user 
 70        (args translate Address -4) map Int := group 
 71        (args translate Address -5) map Int := input 
 72        (args translate Address -6) map Int := output 
 73        (args translate Address -7) map Int := err 
 74        (args translate Address -8) map Address := envptr 
 75        (args translate Address nb) map Address := null 
 76        if nb<>0 
 77          var Pointer:ThreadHeader :> allocate_stack 
 78          if addressof:h=null 
 79            retcode := undefined 
 80            return 
 81          address := args 
 82          if detached 
 83            var Int pid := os_clone 8000h (addressof:translate Byte -256) 
 84            if pid=0 
 85              :> current_thread_header 
 86              pid := os_getpid 
 87              os_setsid 
 88              if ((h:address translate Address -1) map Address)<>null 
 89                os_chdir ((h:address translate Address -1) map CStr) 
 90              if ((h:address translate Address -2) map Address)<>null 
 91                os_chroot ((h:address translate Address -2) map CStr) 
 92              if ((h:address translate Address -4) map Int)=defined 
 93                os_setgid ((h:address translate Address -4) map Int) 
 94              if ((h:address translate Address -3) map Int)=defined 
 95                os_setuid ((h:address translate Address -3) map Int) 
 96              if ((h:address translate Address -5) map Int)=defined 
 97                os_dup2 ((h:address translate Address -5) map Int) 0 
 98              if ((h:address translate Address -6) map Int)=defined 
 99                os_dup2 ((h:address translate Address -6) map Int) 1 
 100              if ((h:address translate Address -7) map Int)=defined 
 101                os_dup2 ((h:address translate Address -7) map Int) 2 
 102              close_handles 
 103              os_execve (h:address map CStr) h:address ((h:address translate Address -8) map Address) 
 104              os_exit 99 
 105            eif pid=(-1) 
 106              retcode := undefined 
 107            else 
 108              id := pid 
 109              var os_timespec spec 
 110              spec tv_sec := 0 
 111              spec tv_nsec := 100*1000^2 
 112              os_nanosleep spec (null map os_timespec) 
 113              retcode := 0 
 114            free_stack h 
 115          else 
 116            var Int pid := os_clone 0 (addressof:translate Byte -256) 
 117            if pid=0 
 118              :> current_thread_header 
 119              pid := os_getpid 
 120              if ((h:address translate Address -1) map Address)<>null 
 121                os_chdir ((h:address translate Address -1) map CStr) 
 122              if ((h:address translate Address -2) map Address)<>null 
 123                os_chroot ((h:address translate Address -2) map CStr) 
 124              if ((h:address translate Address -4) map Int)=defined 
 125                os_setgid ((h:address translate Address -4) map Int) 
 126              if ((h:address translate Address -3) map Int)=defined 
 127                os_setuid ((h:address translate Address -3) map Int) 
 128              if ((h:address translate Address -5) map Int)=defined 
 129                os_dup2 ((h:address translate Address -5) map Int) 0 
 130              if ((h:address translate Address -6) map Int)=defined 
 131                os_dup2 ((h:address translate Address -6) map Int) 1 
 132              if ((h:address translate Address -7) map Int)=defined 
 133                os_dup2 ((h:address translate Address -7) map Int) 2 
 134              close_handles 
 135              os_execve (h:address map CStr) h:address ((h:address translate Address -8) map Address) 
 136              os_exit 99 
 137            eif pid=(-1) 
 138              retcode := undefined 
 139            else 
 140              id := pid 
 141              os_waitpid pid (var Int status) 80000000h 
 142              retcode := (status .and. 0FF00h)\100h 
 143            free_stack h 
 144        else 
 145          retcode := undefined 
 146        for (var Int i) -nb-1 
 147          memory_free ((args translate Address i) map Address) 
 148        memory_free (args translate Address -8) 
 149   
 150    gvar Array:Str paths 
 151    paths += "/sbin/" 
 152    paths += "/bin/" 
 153    paths += "/usr/sbin/" 
 154    paths += "/usr/bin/" 
 155    paths += "/usr/local/sbin/" 
 156    paths += "/usr/local/bin/" 
 157    paths += "/usr/X11R6/bin/" 
 158   
 159    gvar List pids 
 160    gvar Sem sem 
 161   
 162    function restore_execute_pids p fh 
 163      arg Address p ; arg Int fh 
 164      pids := var List empty_list 
 165    gvar DelayedAction restore 
 166    restore function :> the_function restore_execute_pids Address Int 
 167    pliant_restore_actions append addressof:restore 
 168   
 169    function execute2 cmd path root user group input output err env detached id -> retcode 
 170      arg Str cmd path root ; arg Int user group ; arg Str input output err env ; arg CBool detached ; arg_w Int id ; arg Int retcode 
 171      sem request 
 172      var Pointer:Arrow :> pids first 
 173      while c<>null 
 174        if (os_waitpid (map Int) (var Int status) 80000001h)=(map Int) 
 175          :> pids remove c 
 176        else 
 177          :> pids next c 
 178      sem release 
 179      id := undefined 
 180      var Stream in_stream out_stream err_stream 
 181      if input<>"" and output=input 
 182        in_stream open input "inherit" in+out+safe 
 183        if in_stream:stream_handle=undefined 
 184          return -6 
 185        out_stream stream_handle := in_stream stream_handle 
 186      else 
 187        if input<>"" 
 188          in_stream open input "inherit" in+safe 
 189          if in_stream:stream_handle=undefined 
 190            return -6 
 191        if output<>"" 
 192          out_stream open output "inherit" out+safe 
 193          if out_stream:stream_handle=undefined 
 194            return -7 
 195      if err<>"" and err<>"mixed" 
 196        err_stream open err "inherit" out+safe 
 197        if err_stream:stream_handle=undefined 
 198          return -8 
 199      var Str cmd2 
 200      if (cmd 0 1)<>"/" and (cmd 0 2)<>"./" 
 201        if path<>"" and (os_lstat file_os_name:path+(cmd 0 (cmd search " " cmd:len)) (var os_stat stat))=0 
 202          cmd2 := cmd 
 203        else 
 204          var Str os_root := file_os_name root ; os_root := os_root 0 (max os_root:len-1 0) 
 205          part scan 
 206            for (var Int i) paths:size-1 
 207              if (os_lstat os_root+paths:i+(cmd 0 (cmd search " " cmd:len)) (var os_stat stat))=0 
 208                cmd2 := paths:i+cmd 
 209                leave scan 
 210            return (-1) 
 211      else 
 212        cmd2 := cmd 
 213      var Address envptr 
 214      if env="" 
 215        envptr := linux_process_env 
 216      else 
 217        var Array:Address ptrs 
 218        var Int := 0 
 219        while { var Int := (env env:len) search "[0]" -1 ; j<>(-1) } 
 220          ptrs += env:characters translate Byte i 
 221          += j+1 
 222        ptrs += null 
 223        envptr := addressof ptrs:0 
 224      retcode := execute1 cmd2 file_os_name:path file_os_name:root user group in_stream:stream_handle out_stream:stream_handle (shunt err<>"mixed" err_stream:stream_handle out_stream:stream_handle) envptr detached id 
 225      if detached and retcode=0 
 226        sem request 
 227        pids append addressof:(new Int id) 
 228        sem release 
 229   
 230  eif os_api="posix" 
 231   
 232    function execute1 cmd path user group input output err -> retcode 
 233      arg Str cmd path ; arg Int user group input output err ; arg Int retcode 
 234      var Address args := memory_allocate (cmd:len+1)*Address:size null 
 235      var Int nb := 0 
 236      var Int base := 0 
 237      for (var Int i) 0 cmd:len 
 238        if i=cmd:len or cmd:i=" " 
 239          if i>base 
 240            var Pointer:Address arg :> (args translate Address nb) map Address 
 241            arg := memory_allocate i-base+1 args 
 242            for (var Int j) base i-1 
 243              (arg translate Byte j-base) map uInt8 := cmd:j:number 
 244            (arg translate Byte i-base) map uInt8 := 0 
 245            nb := nb+1 
 246          base := i+1 
 247      if path<>"" 
 248        os_chdir path 
 249      if group=defined 
 250        os_setgid group 
 251      if user=defined 
 252        os_setuid user 
 253      if input=defined 
 254        os_dup2 input 0 
 255      if output=defined 
 256        os_dup2 output 1 
 257      if err=defined 
 258        os_dup2 err 2 
 259      os_execvp (args map CStr) args 
 260      for (var Int i) 0 nb-1 
 261        memory_free ((args translate Address i) map Address) 
 262      memory_free args 
 263   
 264    gvar Array:Str paths 
 265    paths += "/sbin/" 
 266    paths += "/bin/" 
 267    paths += "/usr/sbin/" 
 268    paths += "/usr/bin/" 
 269    paths += "/usr/local/sbin/" 
 270    paths += "/usr/local/bin/" 
 271    paths += "/usr/X11R6/bin/" 
 272   
 273    function execute2 cmd path root user group input output err env detached id -> retcode 
 274      arg Str cmd path root ; arg Int user group ; arg Str input output err env ; arg CBool detached ; arg_w Int id ; arg Int retcode 
 275      id := undefined 
 276      if root<>"" 
 277        return -3 
 278      if detached 
 279        return -9 
 280      var Stream in_stream out_stream err_stream 
 281      if input<>"" and output=input 
 282        in_stream open input "inherit" in+out+safe 
 283        if in_stream:stream_handle=undefined 
 284          return -6 
 285        out_stream stream_handle := in_stream stream_handle 
 286      else 
 287        if input<>"" 
 288          in_stream open input "inherit" in+safe 
 289          if in_stream:stream_handle=undefined 
 290            return -6 
 291        if output<>"" 
 292          out_stream open output "inherit" out+safe 
 293          if out_stream:stream_handle=undefined 
 294            return -7 
 295      if err<>"" and err<>"mixed" 
 296        err_stream open err "inherit" out+safe 
 297        if out_stream:stream_handle=undefined 
 298          return -8 
 299      var Str cmd2 
 300      if (cmd 0 1)<>"/" and (cmd 0 2)<>"./" 
 301        if path<>"" and (os_lstat file_os_name:path+(cmd 0 (cmd search " " cmd:len)) (var os_stat stat))=0 
 302          cmd2 := cmd 
 303        else 
 304          part scan 
 305            for (var Int i) 0 paths:size-1 
 306              if (os_lstat paths:i+(cmd 0 (cmd search " " cmd:len)) (var os_stat stat))=0 
 307                cmd2 := paths:i+cmd 
 308                leave scan 
 309            return (-1) 
 310      else 
 311        cmd2 := cmd 
 312      retcode := execute1 cmd2 file_os_name:path user group in_stream:stream_handle out_stream:stream_handle (shunt err<>"mixed" err_stream:stream_handle out_stream:stream_handle) 
 313   
 314  eif os_api="os2" 
 315   
 316    function execute2 cmd path root user group in out err env detached id -> retcode 
 317      arg Str cmd path root ; arg Int user group ; arg Str in out err env ; arg CBool detached ; arg_w Int id ; arg Int retcode 
 318      id := undefined 
 319      if path<>"" 
 320        return -2 
 321      if root<>"" 
 322        return -3 
 323      if user<>"" 
 324        return -4 
 325      if group<>"" 
 326        return -5 
 327      if in<>"" 
 328        return -6 
 329      if out<>"" 
 330        return -7 
 331      if err<>"" 
 332        return -8 
 333      if detached 
 334        return -9 
 335      var Int l := cmd search " " cmd:len 
 336      var Str progname := (cmd 0 l)+"[0]" 
 337      var Str args := progname+(cmd l+1 cmd:len)+"[0][0]" 
 338      var Array:uInt8 buf ; buf size := 260 
 339      var os_RESULTCODES returncodes 
 340      if (os_DosExecPgm (addressof buf:0) buf:size EXEC_SYNC args:characters null returncodes progname:characters)<>0 
 341        retcode := undefined ; return 
 342      return returncodes:codeResult 
 343   
 344  else 
 345   
 346     function execute2 cmd path root user group in out err env detached id -> retcode 
 347       arg Str cmd path root ; arg Int user group ; arg Str in out err env ; arg CBool detached ; arg_w Int id ; arg Int retcode 
 348       return -1 
 349   
 350   
 351  meta execute e 
 352    if e:size<or not (e:cast Str) 
 353      return 
 354    var Link:Argument path :> argument constant Str "" 
 355    var Link:Argument root :> argument constant Str "" 
 356    var Link:Argument user :> argument constant Int undefined 
 357    var Link:Argument group :> argument constant Int undefined 
 358    var Link:Argument input :> argument constant Str "" 
 359    var Link:Argument output :> argument constant Str "" 
 360    var Link:Argument output0 :> output 
 361    var Link:Argument err :> argument constant Str "" 
 362    var Link:Argument env :> argument constant Str "" 
 363    var Link:Argument detached :> argument constant CBool false 
 364    var Link:Argument id :> argument local Int 
 365    var Int := 1 
 366    while i<e:size 
 367      if e:i:ident="path" and i+1<e:size and (e:(i+1) cast Str) 
 368        suckup e:(i+1) 
 369        path :> e:(i+1) result 
 370        += 2 
 371      eif e:i:ident="root" and i+1<e:size and (e:(i+1) cast Str) 
 372        suckup e:(i+1) 
 373        root :> e:(i+1) result 
 374        += 2 
 375      eif e:i:ident="user" and i+1<e:size and (e:(i+1) cast Int) 
 376        suckup e:(i+1) 
 377        user :> e:(i+1) result 
 378        += 2 
 379      eif e:i:ident="group" and i+1<e:size and (e:(i+1) cast Int) 
 380        suckup e:(i+1) 
 381        group :> e:(i+1) result 
 382        += 2 
 383      eif e:i:ident="input" and i+1<e:size and (e:(i+1) cast Str) 
 384        suckup e:(i+1) 
 385        input :> e:(i+1) result 
 386        += 2 
 387      eif e:i:ident="output" and i+1<e:size and (e:(i+1) cast Str) 
 388        suckup e:(i+1) 
 389        output :> e:(i+1) result 
 390        += 2 
 391      eif e:i:ident="error" and i+1<e:size and (e:(i+1) cast Str) 
 392        suckup e:(i+1) 
 393        err :> e:(i+1) result 
 394        += 2 
 395      eif e:i:ident="mixed" 
 396        err :> argument constant Str "mixed" 
 397        += 1 
 398      eif e:i:ident="quiet" 
 399        if addressof:output=addressof:output0 
 400          output :> argument constant Str "device:/null" 
 401        err :> argument constant Str "device:/null" 
 402        += 1 
 403      eif e:i:ident="environment" and i+1<e:size and (e:(i+1) cast Str) 
 404        suckup e:(i+1) 
 405        env :> e:(i+1) result 
 406        += 2 
 407      eif e:i:ident="detached" 
 408        detached :> argument constant CBool true 
 409        += 1 
 410      eif e:i:ident="id" and i+1<e:size and (e:(i+1) cast Int) and (e:(i+1):access .and. access_write)<>0 
 411        suckup e:(i+1) 
 412        id :> e:(i+1) result 
 413        += 2 
 414      else 
 415        return 
 416    var Link:Argument :> argument local Int 
 417    suckup e:0 
 418    add (instruction (the_function execute2 Str Str Str Int Int Str Str Str Str CBool Int -> Int) e:0:result path root user group input output err env detached id r) 
 419    set_result access_read 
 420   
 421  export execute 
 422