1 (* HCoop
Domtool (http
://hcoop
.sourceforge
.net
/)
2 * Copyright (c
) 2006, Adam Chlipala
4 * This program is free software
; you can redistribute it
and/or
5 * modify it under the terms
of the GNU General Public License
6 * as published by the Free Software Foundation
; either version
2
7 * of the License
, or (at your option
) any later version
.
9 * This program is distributed
in the hope that it will be useful
,
10 * but WITHOUT ANY WARRANTY
; without even the implied warranty
of
11 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE
. See the
12 * GNU General Public License for more details
.
14 * You should have received a copy
of the GNU General Public License
15 * along
with this program
; if not
, write to the Free Software
16 * Foundation
, Inc
., 51 Franklin Street
, Fifth Floor
, Boston
, MA
02110-1301, USA
.
19 (* Domain
-related primitive actions
*)
21 structure Domain
:> DOMAIN
= struct
23 fun isIdent ch
= Char.isLower ch
orelse Char.isDigit ch
26 size s
> 0 andalso size s
< 20
27 andalso CharVector
.all (fn ch
=> isIdent ch
orelse ch
= #
"-") s
30 size s
> 0 andalso size s
< 100
31 andalso List.all
validHost (String.fields (fn ch
=> ch
= #
".") s
)
33 val _
= Env
.type_one
"host"
37 val _
= Env
.type_one
"domain"
43 val befores
= ref (fn (_
: string) => ())
44 val afters
= ref (fn (_
: string) => ())
46 fun registerBefore f
=
50 befores
:= (fn x
=> (old x
; f x
))
57 afters
:= (fn x
=> (old x
; f x
))
61 val currentPath
= ref
""
63 fun currentDomain () = !current
65 fun domainFile name
= TextIO.openOut (!currentPath ^ name
)
69 val toks
= String.fields (fn ch
=> ch
= #
".") domain
71 val elems
= foldr (fn (piece
, elems
) =>
73 val elems
= piece
:: elems
74 val path
= String.concatWith
"/" (Config
.resultRoot
:: rev elems
)
76 (if Posix
.FileSys
.ST
.isDir
77 (Posix
.FileSys
.stat path
) then
80 (OS
.FileSys
.remove path
;
81 OS
.FileSys
.mkDir path
))
82 handle OS
.SysErr _
=> OS
.FileSys
.mkDir path
;
86 String.concatWith
"/" (Config
.resultRoot
:: rev ("" :: elems
))
89 val _
= Env
.container_one
"domain"
90 ("domain", Env
.string)
91 (fn dom
=> (current
:= dom
;
92 currentPath
:= getPath dom
;
94 fn () => !afters (!current
))