Merge branch 'master' of git://factorcode.org/git/factor

basis/calendar/calendar-docs.factor

@@ -36,7 +36,7 @@ HELP: month-name
 { $description "Looks up the month name and returns it as a string.  January has an index of 1 instead of zero." } ;
 
 HELP: month-abbreviations
-{ $values { "array" array } }
+{ $values { "value" array } }
 { $description "Returns an array with the English abbreviated names of all the months." }
 { $warning "Do not use this array for looking up a month name directly. Use month-abbreviation instead." } ;
 
@@ -54,7 +54,7 @@ HELP: day-name
 { $description "Looks up the day name and returns it as a string." } ;
 
 HELP: day-abbreviations2
-{ $values { "array" array } }
+{ $values { "value" array } }
 { $description "Returns an array with the abbreviated English names of the days of the week.  This abbreviation is two characters long." } ;
 
 HELP: day-abbreviation2
@@ -62,7 +62,7 @@ HELP: day-abbreviation2
 { $description "Looks up the abbreviated day name and returns it as a string. This abbreviation is two characters long." } ;
 
 HELP: day-abbreviations3
-{ $values { "array" array } }
+{ $values { "value" array } }
 { $description "Returns an array with the abbreviated English names of the days of the week.  This abbreviation is three characters long." } ;
 
 HELP: day-abbreviation3

basis/images/bitmap/bitmap.factor

@@ -6,14 +6,23 @@ kernel macros math math.bitwise math.functions namespaces sequences
 strings images endian summary ;
 IN: images.bitmap
 
-TUPLE: bitmap-image < image
+: assert-sequence= ( a b -- )
-magic size reserved offset header-length width
+    2dup sequence= [ 2drop ] [ assert ] if ;
+
+: read2 ( -- n ) 2 read le> ;
+: read4 ( -- n ) 4 read le> ;
+: write2 ( n -- ) 2 >le write ;
+: write4 ( n -- ) 4 >le write ;
+
+TUPLE: bitmap-image < image ;
+
+! Used to construct the final bitmap-image
+
+TUPLE: loading-bitmap 
+size reserved offset header-length width
 height planes bit-count compression size-image
 x-pels y-pels color-used color-important rgb-quads color-index ;
 
-! Currently can only handle 24/32bit bitmaps.
-! Handles row-reversed bitmaps (their height is negative)
-
 ERROR: bitmap-magic magic ;
 
 M: bitmap-magic summary
@@ -21,37 +30,31 @@ M: bitmap-magic summary
 
 <PRIVATE
 
-: array-copy ( bitmap array -- bitmap array' )
-    over size-image>> abs memory>byte-array ;
-
 : 8bit>buffer ( bitmap -- array )
     [ rgb-quads>> 4 <sliced-groups> [ 3 head-slice ] map ]
     [ color-index>> >array ] bi [ swap nth ] with map concat ;
 
 ERROR: bmp-not-supported n ;
 
-: raw-bitmap>buffer ( bitmap -- array )
+: reverse-lines ( byte-array width -- byte-array )
+    3 * <sliced-groups> <reversed> concat ; inline
+
+: raw-bitmap>seq ( loading-bitmap -- array )
     dup bit-count>>
     {
         { 32 [ color-index>> ] }
-        { 24 [ color-index>> ] }
+        { 24 [ [ color-index>> ] [ width>> ] bi reverse-lines ] }
-        { 16 [ bmp-not-supported ] }
+        { 8 [ [ 8bit>buffer ] [ width>> ] bi reverse-lines ] }
-        { 8 [ 8bit>buffer ] }
+        [ bmp-not-supported ]
-        { 4 [ bmp-not-supported ] }
-        { 2 [ bmp-not-supported ] }
-        { 1 [ bmp-not-supported ] }
     } case >byte-array ;
 
-: read2 ( -- n ) 2 read le> ;
+: parse-file-header ( loading-bitmap -- loading-bitmap )
-: read4 ( -- n ) 4 read le> ;
+    2 read "BM" assert-sequence=
-
-: parse-file-header ( bitmap -- bitmap )
-    2 read dup "BM" sequence= [ bitmap-magic ] unless >>magic
     read4 >>size
     read4 >>reserved
     read4 >>offset ;
 
-: parse-bitmap-header ( bitmap -- bitmap )
+: parse-bitmap-header ( loading-bitmap -- loading-bitmap )
     read4 >>header-length
     read4 >>width
     read4 >>height
@@ -64,10 +67,10 @@ ERROR: bmp-not-supported n ;
     read4 >>color-used
     read4 >>color-important ;
 
-: rgb-quads-length ( bitmap -- n )
+: rgb-quads-length ( loading-bitmap -- n )
     [ offset>> 14 - ] [ header-length>> ] bi - ;
 
-: color-index-length ( bitmap -- n )
+: color-index-length ( loading-bitmap -- n )
     {
         [ width>> ]
         [ planes>> * ]
@@ -75,21 +78,18 @@ ERROR: bmp-not-supported n ;
         [ height>> abs * ]
     } cleave ;
 
-: parse-bitmap ( bitmap -- bitmap )
+: parse-bitmap ( loading-bitmap -- loading-bitmap )
     dup rgb-quads-length read >>rgb-quads
     dup color-index-length read >>color-index ;
 
-: load-bitmap-data ( path bitmap -- bitmap )
+: load-bitmap-data ( path loading-bitmap -- loading-bitmap )
     [ binary ] dip '[
         _ parse-file-header parse-bitmap-header parse-bitmap
     ] with-file-reader ;
 
-: process-bitmap-data ( bitmap -- bitmap )
-    dup raw-bitmap>buffer >>bitmap ;
-
 ERROR: unknown-component-order bitmap ;
 
-: bitmap>component-order ( bitmap -- object )
+: bitmap>component-order ( loading-bitmap -- object )
     bit-count>> {
         { 32 [ BGRA ] }
         { 24 [ BGR ] }
@@ -97,61 +97,66 @@ ERROR: unknown-component-order bitmap ;
         [ unknown-component-order ]
     } case ;
 
-: fill-image-slots ( bitmap -- bitmap )
+: loading-bitmap>bitmap-image ( loading-bitmap -- bitmap-image )
-    dup {
+    [ bitmap-image new ] dip
+    {
+        [ raw-bitmap>seq >>bitmap ]
         [ [ width>> ] [ height>> ] bi 2array >>dim ]
         [ bitmap>component-order >>component-order ]
-        [ bitmap>> >>bitmap ]
     } cleave ;
 
-M: bitmap-image load-image* ( path bitmap -- bitmap )
+M: bitmap-image load-image* ( path loading-bitmap -- bitmap )
-    load-bitmap-data process-bitmap-data
+    drop loading-bitmap new
-    fill-image-slots ;
+    load-bitmap-data
-
+    loading-bitmap>bitmap-image ;
-MACRO: (nbits>bitmap) ( bits -- )
-    [ -3 shift ] keep '[
-        bitmap-image new
-            2over * _ * >>size-image
-            swap >>height
-            swap >>width
-            swap array-copy [ >>bitmap ] [ >>color-index ] bi
-            _ >>bit-count fill-image-slots
-            t >>upside-down?
-    ] ;
-
-: bgr>bitmap ( array height width -- bitmap )
-    24 (nbits>bitmap) ;
-
-: bgra>bitmap ( array height width -- bitmap )
-    32 (nbits>bitmap) ;
-
-: write2 ( n -- ) 2 >le write ;
-: write4 ( n -- ) 4 >le write ;
 
 PRIVATE>
 
-: save-bitmap ( bitmap path -- )
+: bitmap>color-index ( bitmap-array -- byte-array )
+    4 <sliced-groups> [ 3 head-slice <reversed> ] map B{ } join ; inline
+
+: save-bitmap ( image path -- )
     binary [
         B{ CHAR: B CHAR: M } write
         [
-            color-index>> length 14 + 40 + write4
+            bitmap>> bitmap>color-index length 14 + 40 + write4
             0 write4
             54 write4
             40 write4
         ] [
             {
-                [ width>> write4 ]
+                ! width height
-                [ height>> write4 ]
+                [ dim>> first2 [ write4 ] bi@ ]
-                [ planes>> 1 or write2 ]
+
-                [ bit-count>> 24 or write2 ]
+                ! planes
-                [ compression>> 0 or write4 ]
+                [ drop 1 write2 ]
-                [ size-image>> write4 ]
+
-                [ x-pels>> 0 or write4 ]
+                ! bit-count
-                [ y-pels>> 0 or write4 ]
+                [ drop 24 write2 ]
-                [ color-used>> 0 or write4 ]
+
-                [ color-important>> 0 or write4 ]
+                ! compression
-                [ rgb-quads>> write ]
+                [ drop 0 write4 ]
-                [ color-index>> write ]
+
+                ! size-image
+                [ bitmap>> bitmap>color-index length write4 ]
+
+                ! x-pels
+                [ drop 0 write4 ]
+
+                ! y-pels
+                [ drop 0 write4 ]
+
+                ! color-used
+                [ drop 0 write4 ]
+
+                ! color-important
+                [ drop 0 write4 ]
+
+                ! rgb-quads
+                [
+                    [ bitmap>> bitmap>color-index ] [ dim>> first ] bi
+                    reverse-lines write
+                ]
             } cleave
         ] bi
     ] with-file-writer ;

basis/smtp/smtp-docs.factor

@@ -73,6 +73,20 @@ HELP: send-email
     }
 } ;
 
+ARTICLE: "smtp-gmail" "Setting up SMTP with gmail"
+"If you plan to send all email from the same address, then setting variables in the global namespace is the best option. The code example below does this approach and is meant to go in your " { $link "factor-boot-rc" } "." $nl
+"Several variables need to be set for sending outgoing mail through gmail. First, we set the login and password to a " { $link <plain-auth> } " tuple with our login. Next, we set the gmail server address with an " { $link <inet> } " object. Finally, we tell the SMTP library to use a secure connection."
+{ $code
+    "USING: smtp namespaces io.sockets ;"
+    ""
+    "\"my.gmail.address@gmail.com\" \"secret-password\" <plain-auth> smtp-auth set-global"
+    ""
+    "\"smtp.gmail.com\" 587 <inet> smtp-server set-global"
+    ""
+    "t smtp-tls? set-global"
+} ;
+
+
 ARTICLE: "smtp" "SMTP client library"
 "The " { $vocab-link "smtp" } " vocabulary sends e-mail via an SMTP server."
 $nl
@@ -89,6 +103,8 @@ $nl
 { $subsection email }
 { $subsection <email> }
 "Sending an email:"
-{ $subsection send-email } ;
+{ $subsection send-email }
+"More topics:"
+{ $subsection "smtp-gmail" } ;
 
 ABOUT: "smtp"

basis/tools/scaffold/scaffold.factor

@@ -5,7 +5,7 @@ io.encodings.utf8 hashtables kernel namespaces sequences
 vocabs.loader io combinators calendar accessors math.parser
 io.streams.string ui.tools.operations quotations strings arrays
 prettyprint words vocabs sorting sets classes math alien urls
-splitting ascii combinators.short-circuit ;
+splitting ascii combinators.short-circuit alarms words.symbol ;
 IN: tools.scaffold
 
 SYMBOL: developer-name
@@ -116,6 +116,7 @@ ERROR: no-vocab vocab ;
         { "ch" "a character" }
         { "word" word }
         { "array" array }
+        { "alarm" alarm }
         { "duration" duration }
         { "path" "a pathname string" }
         { "vocab" "a vocabulary specifier" }
@@ -134,7 +135,7 @@ ERROR: no-vocab vocab ;
 
 : ($values.) ( array -- )
     [
-        " { " write
+        "{ " write
         dup array? [ first ] when
         dup lookup-type [
             [ unparse write bl ]
@@ -162,15 +163,26 @@ ERROR: no-vocab vocab ;
         ] if
     ] when* ;
 
+: symbol-description. ( word -- )
+    drop
+    "{ $var-description \"\" } ;" print ;
+
 : $description. ( word -- )
     drop
     "{ $description \"\" } ;" print ;
 
+: docs-body. ( word/symbol -- )
+    dup symbol? [
+        symbol-description.
+    ] [
+        [ $values. ] [ $description. ] bi
+    ] if ;
+
 : docs-header. ( word -- )
     "HELP: " write name>> print ;
 
 : (help.) ( word -- )
-    [ docs-header. ] [ $values. ] [ $description. ] tri ;
+    [ docs-header. ] [ docs-body. ] bi ;
 
 : interesting-words ( vocab -- array )
     words

extra/site-watcher/authors.txt

@@ -0,0 +1 @@
+Doug Coleman

extra/site-watcher/site-watcher-docs.factor

@@ -0,0 +1,60 @@
+! Copyright (C) 2009 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: assocs help.markup help.syntax kernel urls alarms calendar ;
+IN: site-watcher
+
+HELP: run-site-watcher
+{ $description "Starts the site-watcher on the assoc stored in " { $link sites } "." } ;
+
+HELP: running-site-watcher
+{ $var-description "A symbol storing the alarm of a running site-watcher if started with the " { $link run-site-watcher } " word. To prevent multiple site-watchers from running, this variable is checked before allowing another site-watcher to start." } ;
+
+HELP: site-watcher-from
+{ $var-description "The email address from which site-watcher sends emails." } ;
+
+HELP: sites
+{ $var-description "A symbol storing an assoc of URLs, data about a site, and who to notify if a site goes down." } ;
+
+HELP: watch-site
+{ $values
+    { "emails" "a string containing an email address, or an array of such" }
+    { "url" url }
+}
+{ $description "Adds a new site to the watch assoc stored in " { $link sites } ", or adds email addresses to an already watched site." } ;
+
+HELP: watch-sites
+{ $values
+    { "assoc" assoc }
+    { "alarm" alarm }
+}
+{ $description "Runs the site-watcher on the input assoc and returns the alarm that times the site check loop. This alarm may be turned off with " { $link cancel-alarm } ", thus stopping the site-watcher." } ;
+
+HELP: site-watcher-frequency
+{ $var-description "A " { $link duration } " specifying how long to wait between checking sites." } ;
+
+HELP: unwatch-site
+{ $values
+    { "emails" "a string containing an email, or an array of such" }
+    { "url" url }
+}
+{ $description "Removes an email address from being notified when a site's goes down. If this email was the last one watching the site, removes the site as well." } ;
+
+HELP: delete-site
+{ $values
+    { "url" url }
+}
+{ $description "Removes a watched site from the " { $link sites } " assoc." } ;
+
+ARTICLE: "site-watcher" "Site watcher"
+"The " { $vocab-link "site-watcher" } " vocabulary monitors websites and sends email when a site goes down or comes up." $nl
+"To monitor a site:"
+{ $subsection watch-site }
+"To stop email addresses from being notified if a site's status changes:"
+{ $subsection unwatch-site }
+"To stop monitoring a site for all email addresses:"
+{ $subsection delete-site }
+"To run site-watcher using the sites variable:"
+{ $subsection run-site-watcher }
+;
+
+ABOUT: "site-watcher"

extra/site-watcher/site-watcher.factor

@@ -0,0 +1,114 @@
+! Copyright (C) 2009 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors alarms assocs calendar combinators
+continuations fry http.client io.streams.string kernel init
+namespaces prettyprint smtp arrays sequences math math.parser
+strings sets ;
+IN: site-watcher
+
+SYMBOL: sites
+
+SYMBOL: site-watcher-from
+
+sites [ H{ } clone ] initialize
+
+TUPLE: watching emails url last-up up? send-email? error ;
+
+<PRIVATE
+
+: ?1array ( array/object -- array )
+    dup array? [ 1array ] unless ; inline
+
+: <watching> ( emails url -- watching )
+    watching new
+        swap >>url
+        swap ?1array >>emails
+        now >>last-up
+        t >>up? ;
+
+ERROR: not-watching-site url status ;
+
+: set-site-flags ( watching new-up? -- watching )
+    [ over up?>> = [ t >>send-email? ] unless ] keep >>up? ;
+
+: site-bad ( watching error -- )
+    >>error f set-site-flags drop ;
+
+: site-good ( watching -- )
+    f >>error
+    t set-site-flags
+    now >>last-up drop ;
+
+: check-sites ( assoc -- )
+    [
+        swap '[ _ http-get 2drop site-good ] [ site-bad ] recover
+    ] assoc-each ;
+
+: site-up-email ( email watching -- email )
+    last-up>> now swap time- duration>minutes 60 /mod
+    [ >integer number>string ] bi@
+    [ " hours, " append ] [ " minutes" append ] bi* append
+    "Site was down for (at least): " prepend >>body ;
+
+: ?unparse ( string/object -- string )
+    dup string? [ unparse ] unless ; inline
+
+: site-down-email ( email watching -- email )
+    error>> ?unparse >>body ;
+
+: send-report ( watching -- )
+    [ <email> ] dip
+    {
+        [ emails>> >>to ]
+        [ drop site-watcher-from get "factor.site.watcher@gmail.com" or >>from ]
+        [ dup up?>> [ site-up-email ] [ site-down-email ] if ]
+        [ [ url>> ] [ up?>> "up" "down" ? ] bi " is " glue >>subject ]
+        [ f >>send-email? drop ]
+    } cleave send-email ;
+
+: report-sites ( assoc -- )
+    [ nip send-email?>> ] assoc-filter
+    [ nip send-report ] assoc-each ;
+
+PRIVATE>
+
+SYMBOL: site-watcher-frequency
+site-watcher-frequency [ 5 minutes ] initialize
+
+: watch-sites ( assoc -- alarm )
+    '[
+        _ [ check-sites ] [ report-sites ] bi
+    ] site-watcher-frequency get every ;
+
+: watch-site ( emails url -- )
+    sites get ?at [
+        [ [ ?1array ] dip append prune ] change-emails drop
+    ] [
+        <watching> dup url>> sites get set-at
+    ] if ;
+
+: delete-site ( url -- )
+    sites get delete-at ;
+
+: unwatch-site ( emails url -- )
+    [ ?1array ] dip
+    sites get ?at [
+        [ diff ] change-emails dup emails>> empty? [
+            url>> delete-site
+        ] [
+            drop
+        ] if 
+    ] [
+        nip delete-site
+    ] if ;
+
+SYMBOL: running-site-watcher
+
+: run-site-watcher ( -- )
+    running-site-watcher get-global [
+        sites get-global watch-sites running-site-watcher set-global
+    ] unless ;
+
+[ f running-site-watcher set-global ] "site-watcher" add-init-hook
+
+MAIN: run-site-watcher