extra/mason/common/common.factor

   1 ! Copyright (C) 2008, 2009 Eduardo Cavazos, Slava Pestov.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: kernel namespaces sequences splitting system accessors
   4 math.functions make io io.files io.pathnames io.directories
   5 io.directories.hierarchy io.launcher io.encodings.utf8 prettyprint
   6 combinators.short-circuit parser combinators math calendar
   7 calendar.format arrays mason.config locals debugger fry
   8 continuations strings io.sockets ;
   9 IN: mason.common
  10
  11 : short-host-name ( -- string )
  12     host-name "." split1 drop ;
  13
  14 SYMBOL: current-git-id
  15
  16 : short-running-process ( command -- )
  17     #! Give network operations and shell commands at most
  18     #! 15 minutes to complete, to catch hangs.
  19     >process 15 minutes >>timeout try-output-process ;
  20
  21 HOOK: really-delete-tree os ( path -- )
  22
  23 M: windows really-delete-tree
  24     #! Workaround: Cygwin GIT creates read-only files for
  25     #! some reason.
  26     [ { "chmod" "ug+rw" "-R" } swap absolute-path suffix short-running-process ]
  27     [ delete-tree ]
  28     bi ;
  29
  30 M: unix really-delete-tree delete-tree ;
  31
  32 : retry ( n quot -- )
  33     '[ drop @ f ] attempt-all drop ; inline
  34
  35 :: upload-safely ( local username host remote -- )
  36     remote ".incomplete" append :> temp
  37     { username "@" host ":" temp } concat :> scp-remote
  38     scp-command get :> scp
  39     ssh-command get :> ssh
  40     5 [ { scp local scp-remote } short-running-process ] retry
  41     5 [ { ssh host "-l" username "mv" temp remote } short-running-process ] retry ;
  42
  43 : eval-file ( file -- obj )
  44     dup utf8 file-lines parse-fresh
  45     [ "Empty file: " swap append throw ] [ nip first ] if-empty ;
  46
  47 : to-file ( object file -- ) utf8 [ . ] with-file-writer ;
  48
  49 : datestamp ( timestamp -- string )
  50     [
  51         {
  52             [ year>> , ]
  53             [ month>> , ]
  54             [ day>> , ]
  55             [ hour>> , ]
  56             [ minute>> , ]
  57         } cleave
  58     ] { } make [ pad-00 ] map "-" join ;
  59
  60 : nanos>time ( n -- string )
  61     1,000,000,000 /i 60 /mod [ 60 /mod ] dip 3array [ pad-00 ] map ":" join ;
  62
  63 SYMBOL: stamp
  64
  65 : builds/factor ( -- path ) builds-dir get "factor" append-path ;
  66 : build-dir ( -- path ) builds-dir get stamp get append-path ;
  67
  68 : prepare-build-machine ( -- )
  69     builds-dir get make-directories
  70     builds-dir get
  71     [ { "git" "clone" "git://factorcode.org/git/factor.git" } try-output-process ]
  72     with-directory ;
  73
  74 : git-id ( -- id )
  75     { "git" "show" } utf8 [ lines ] with-process-reader
  76     first " " split second ;
  77
  78 : ?prepare-build-machine ( -- )
  79     builds/factor exists? [ prepare-build-machine ] unless ;
  80
  81 CONSTANT: load-all-vocabs-file "load-everything-vocabs"
  82 CONSTANT: load-all-errors-file "load-everything-errors"
  83
  84 CONSTANT: test-all-vocabs-file "test-all-vocabs"
  85 CONSTANT: test-all-errors-file "test-all-errors"
  86
  87 CONSTANT: help-lint-vocabs-file "help-lint-vocabs"
  88 CONSTANT: help-lint-errors-file "help-lint-errors"
  89
  90 CONSTANT: compiler-errors-file "compiler-errors"
  91 CONSTANT: compiler-error-messages-file "compiler-error-messages"
  92
  93 CONSTANT: boot-time-file "boot-time"
  94 CONSTANT: load-time-file "load-time"
  95 CONSTANT: test-time-file "test-time"
  96 CONSTANT: help-lint-time-file "help-lint-time"
  97 CONSTANT: benchmark-time-file "benchmark-time"
  98 CONSTANT: html-help-time-file "html-help-time"
  99
 100 CONSTANT: benchmarks-file "benchmarks"
 101 CONSTANT: benchmark-error-messages-file "benchmark-error-messages"
 102 CONSTANT: benchmark-error-vocabs-file "benchmark-error-vocabs"
 103
 104 SYMBOL: status-error ! didn't bootstrap, or crashed
 105 SYMBOL: status-dirty ! bootstrapped but not all tests passed
 106 SYMBOL: status-clean ! everything good