Fix 'extra/update'

extra/update/backup/backup.factor

@@ -0,0 +1,28 @@
+
+USING: namespaces debugger io.files bootstrap.image update.util ;
+
+IN: update.backup
+
+: backup-boot-image ( -- )
+  my-boot-image-name
+  { "boot." my-arch "-" [ "datestamp" get ] ".image" } to-string  
+  move-file ;
+
+: backup-image ( -- )
+  "factor.image"
+  { "factor" "-" [ "datestamp" get ] ".image" } to-string
+  move-file ;
+
+: backup-vm ( -- )
+  "factor"
+  { "factor" "-" [ "datestamp" get ] } to-string
+  move-file ;
+
+: backup ( -- )
+  datestamp "datestamp" set
+    [
+      backup-boot-image
+      backup-image
+      backup-vm
+    ]
+  try ;

extra/update/latest/latest.factor

@@ -0,0 +1,53 @@
+
+USING: kernel namespaces system io.files bootstrap.image http.client
+       update update.backup update.util ;
+
+IN: update.latest
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: git-pull-master ( -- )
+  image parent-directory
+    [
+      { "git" "pull" "git://factorcode.org/git/factor.git" "master" }
+      run-command
+    ]
+  with-directory ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: remote-latest-image ( -- url )
+  { "http://factorcode.org/images/latest/" my-boot-image-name } to-string ;
+
+: download-latest-image ( -- ) remote-latest-image download ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: rebuild-latest ( -- )
+  image parent-directory
+    [
+      backup
+      download-latest-image
+      make-clean
+      make
+      boot
+    ]
+  with-directory ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: update-latest ( -- )
+  image parent-directory
+    [
+      git-id
+      git-pull-master
+      git-id
+      = not
+        [ rebuild-latest ]
+      when
+    ]
+  with-directory ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+MAIN: update-latest

extra/update/update.factor

@@ -0,0 +1,66 @@
+
+USING: kernel system sequences io.files io.launcher bootstrap.image
+       http.client
+       update.util ;
+
+       ! builder.util builder.release.branch ;
+
+IN: update
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: run-command ( cmd -- ) to-strings try-process ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: git-pull-clean ( -- )
+  image parent-directory
+    [
+      { "git" "pull" "git://factorcode.org/git/factor.git" branch-name }
+      run-command
+    ]
+  with-directory ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: remote-clean-image ( -- url )
+  { "http://factorcode.org/images/clean/" platform "/" my-boot-image-name }
+  to-string ;
+
+: download-clean-image ( -- ) remote-clean-image download ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: make-clean ( -- ) { gnu-make "clean" } run-command ;
+: make       ( -- ) { gnu-make         } run-command ;
+: boot       ( -- ) { "./factor" { "-i=" my-boot-image-name } } run-command ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: rebuild ( -- )
+  image parent-directory
+    [
+      download-clean-image
+      make-clean
+      make
+      boot
+    ]
+  with-directory ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: update ( -- )
+  image parent-directory
+    [
+      git-id
+      git-pull-clean
+      git-id
+      = not
+        [ rebuild ]
+      when
+    ]
+  with-directory ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+MAIN: update

extra/update/util/util.factor

@@ -0,0 +1,62 @@
+
+USING: kernel classes strings quotations words math math.parser arrays
+       combinators.cleave
+       accessors
+       system prettyprint splitting
+       sequences combinators sequences.deep
+       io
+       io.launcher
+       io.encodings.utf8
+       calendar
+       calendar.format ;
+
+IN: update.util
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+DEFER: to-strings
+
+: to-string ( obj -- str )
+  dup class
+    {
+      { \ string    [ ] }
+      { \ quotation [ call ] }
+      { \ word      [ execute ] }
+      { \ fixnum    [ number>string ] }
+      { \ array     [ to-strings concat ] }
+    }
+  case ;
+
+: to-strings ( seq -- str )
+  dup [ string? ] all?
+    [ ]
+    [ [ to-string ] map flatten ]
+  if ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: cpu- ( -- cpu ) cpu unparse "." split "-" join ;
+
+: platform ( -- string ) { [ os unparse ] cpu- } to-strings "-" join ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: branch-name ( -- string ) "clean-" platform append ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: gnu-make ( -- string )
+  os { freebsd openbsd netbsd } member? [ "gmake" ] [ "make" ] if ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: git-id ( -- id )
+  { "git" "show" } utf8 <process-reader> [ readln ] with-input-stream
+  " " split second ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: datestamp ( -- string )
+  now
+    { year>> month>> day>> hour>> minute>> } <arr>
+  [ pad-00 ] map "-" join ;