├── .gitignore ├── .merlin ├── CHANGES.md ├── LICENSE.md ├── Makefile ├── README.md ├── TODO ├── _tags ├── descr ├── doc ├── api.odocl ├── dev-faq.txt ├── dot │ └── style.css ├── make-index.sed ├── postprocess.ml ├── style.css └── tutorial.ml ├── examples ├── amb.ml ├── amb.sh ├── args.ml ├── curl-amb.ml ├── daedelus.ml ├── downsample.ml ├── init-git-svn.sh ├── notify.ml ├── pgrep.ml ├── ppool.ml ├── shmencode.ml ├── timeout.ml ├── wait.ml └── wait.sh ├── lib ├── abort.ml ├── abort.mli ├── adaptor.ml ├── adaptor.mli ├── anyShtream.ml ├── anyShtream.mli ├── channel.ml ├── channel.mli ├── delimited.ml ├── delimited.mli ├── depDAG.ml ├── depDAG.mli ├── disposal.ml ├── disposal.mli ├── fitting.ml ├── fitting.mli ├── fittingSig.ml ├── flags.mli ├── flags.mll ├── iVar.ml ├── iVar.mli ├── line.ml ├── line.mli ├── lineShtream.ml ├── lineShtream.mli ├── priorityQueue.ml ├── priorityQueue.mli ├── proc.cppo.ml ├── proc.mli ├── reader.ml ├── reader.mli ├── shcaml.mllib ├── shcaml.mlpack ├── shcaml_top.ml ├── shcaml_top.mllib ├── shcaml_top_init.ml ├── shtream.ml ├── shtream.mli ├── signal.ml ├── signal.mli ├── stringShtream.ml ├── stringShtream.mli ├── tst.ml ├── usrBin.ml ├── usrBin.mli ├── util.ml ├── version.ml ├── version.mli ├── weakPlus.ml └── weakPlus.mli ├── myocamlbuild.ml ├── opam ├── pkg ├── META └── pkg.ml └── tests ├── basic_line_test.ml ├── basic_line_test_driver.ml ├── csv.ml ├── dup_protect.ml ├── fail ├── pass ├── sequencing.sh └── test_lib.sh /.gitignore: -------------------------------------------------------------------------------- 1 | .*sw? 2 | lib/flags.ml 3 | doc/INDEX 4 | doc/api.docdir 5 | doc/man 6 | *.o 7 | *.cmi 8 | *.cmo 9 | *.cmx 10 | *.doc 11 | *.doci 12 | _build 13 | shcaml.install 14 | api.docdir -------------------------------------------------------------------------------- /.merlin: -------------------------------------------------------------------------------- 1 | B _build 2 | B _build/lib 3 | PKG pcre 4 | PKG unix 5 | PKG hmap 6 | PKG lwt.unix 7 | PKG compiler-libs 8 | PKG lambdasoup -------------------------------------------------------------------------------- /CHANGES.md: -------------------------------------------------------------------------------- 1 | Caml-Shcaml 0.2.0 2 | ----------------- 3 | 4 | - Drop the dependency on camlp4, mainly by replacing the static typing of 5 | structured fields by a lighter, dynamically-checked discipline. This trades 6 | static guarantees for maintenability. 7 | 8 | - Build system changes, switch to ocamlbuild+topkg 9 | 10 | - Some API refactoring; improve API browsing at the price of some signature 11 | duplication in the source. 12 | 13 | - Documentation improvements 14 | 15 | Caml-Shcaml 0.1.2 16 | ----------------- 17 | - [23 Sep 2008] We no longer distinguish input and output dups. This 18 | change is because the old way we did it no longer types under 3.10.2. 19 | There is probably a better way. 20 | 21 | - [19 Sep 2008] Added DepDAG module for running dependency DAGs in 22 | parallel. 23 | 24 | - [19 Sep 2008] Added Fitting.run_list as a convenient fitting runner. 25 | 26 | Caml-Shcaml 0.1.1 27 | ----------------- 28 | 29 | - [05 Feb 2008] Sed script used to build documentation is now portable; 30 | no longer relies on GNU sed. 31 | 32 | - [05 Feb 2008] Now supports (and in fact requires) OCaml 3.10. (Should 33 | we somehow make it work in both? Seems like a pain.) 34 | 35 | - [07 Aug 2007, 05 Feb 2008] pa_linetype now supports anonymous row 36 | variables, such as <| .. >. When the entire row is anonymous, it 37 | expands to < .. > rather than a list of fields. 38 | 39 | - [15 Aug 2007] Several places that used to use ints for process statuses 40 | now use Proc.status instead. 41 | 42 | Caml-Shcaml 0.1.0 43 | ----------------- 44 | 45 | - [06 Aug 2007] Initial release 46 | -------------------------------------------------------------------------------- /LICENSE.md: -------------------------------------------------------------------------------- 1 | Copyright (c) 2007 Alec Heller and Jesse Tov 2 | 3 | Permission is hereby granted, free of charge, to any person obtaining a copy 4 | of this software and associated documentation files (the "Software"), to deal 5 | in the Software without restriction, including without limitation the rights 6 | to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 7 | copies of the Software, and to permit persons to whom the Software is 8 | furnished to do so, subject to the following conditions: 9 | 10 | The above copyright notice and this permission notice shall be included in 11 | all copies or substantial portions of the Software. 12 | 13 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 14 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 15 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 16 | AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 17 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 18 | OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN 19 | THE SOFTWARE. 20 | -------------------------------------------------------------------------------- /Makefile: -------------------------------------------------------------------------------- 1 | .PHONY: lib doc clean 2 | 3 | lib: 4 | ocaml pkg/pkg.ml build 5 | 6 | doc: 7 | topkg doc 8 | 9 | clean: 10 | topkg clean 11 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # Shcaml 2 | 3 | Shcaml is an OCaml library for Unix shell programming. 4 | 5 | Unix shells provide easy access to Unix functionality such as pipes, signals, 6 | file descriptor manipulation, and the file system. Shcaml hopes to excel at 7 | these same tasks. 8 | 9 | ## Installation 10 | 11 | Shcaml can be installed with `opam`: 12 | 13 | opam install shcaml 14 | 15 | If you don't use `opam` consult the [`opam`](opam) file for build 16 | instructions. 17 | 18 | ## Documentation & tutorial 19 | 20 | You can find Shcaml's documentation (including a tutorial) online at 21 | http://tov.github.io/shcaml/doc or build a local copy with `make 22 | doc`. 23 | 24 | See also the [companion 25 | paper](http://users.cs.northwestern.edu/~jesse/pubs/caml-shcaml/). Note than 26 | as of Shcaml 0.2.0 and onwards, the solution to encode row types described in 27 | section 4.3 has been replaced by a more lightweight policy, where the absence or 28 | presence of fields is only checked dynamically. This trades static guarantees 29 | for maintainability of the library. 30 | -------------------------------------------------------------------------------- /TODO: -------------------------------------------------------------------------------- 1 | CSV should allow separators longer than one character. 2 | 3 | Shmyntax. 4 | 5 | Making redirection as lazy as piping so things don't reorder improperly. 6 | 7 | Proc.command (and friends) that takes a format string with quoting 8 | specifiers. 9 | 10 | There's no need for linespec.ml to handle its own docstrings anymore, 11 | since camlp4 now handles comments alright. We could actually use a 12 | regular old filter. 13 | 14 | We really ought to get rid of lines. Arrows would work better. We'll 15 | need arrow notation syntax. How does this affect readers and splitters? 16 | (One valiant attempt at this has failed.) 17 | 18 | Campl4 is dropping many of our docstrings on the floor. 19 | -------------------------------------------------------------------------------- /_tags: -------------------------------------------------------------------------------- 1 | true: bin_annot 2 | true: package(pcre), package(hmap), package(unix), package(stdcompat) 3 | "lib": include 4 | 5 | and not : for-pack(Shcaml) 6 | : package(compiler-libs) 7 | : package(lambdasoup) 8 | : html 9 | -------------------------------------------------------------------------------- /descr: -------------------------------------------------------------------------------- 1 | Library for Unix shell programming -------------------------------------------------------------------------------- /doc/api.odocl: -------------------------------------------------------------------------------- 1 | lib/Abort 2 | lib/Adaptor 3 | lib/AnyShtream 4 | lib/Channel 5 | lib/Delimited 6 | lib/DepDAG 7 | lib/Disposal 8 | lib/Fitting 9 | lib/FittingSig 10 | lib/Flags 11 | lib/IVar 12 | lib/Line 13 | lib/LineShtream 14 | lib/PriorityQueue 15 | lib/Proc 16 | lib/Reader 17 | lib/Shtream 18 | lib/Signal 19 | lib/StringShtream 20 | lib/Util 21 | lib/UsrBin 22 | lib/Version 23 | lib/WeakPlus 24 | -------------------------------------------------------------------------------- /doc/dev-faq.txt: -------------------------------------------------------------------------------- 1 | DEV-FAQ 2 | ======= 3 | 4 | Questions 5 | --------- 6 | 7 | Why do all the line types in the sources look like 8 | instead of <| .. as 'a >? 9 | 10 | Expanding the <| > syntax requires generating identifiers that refer 11 | to types and values in the Shcaml.Line module, such as 12 | Shcaml.Line.present. End-users see the Line module as nested inside 13 | the Shcaml module, so syntax/pa_linetype.ml generates the 14 | identifiers qualified with Shcaml.Line. However, when compiling our 15 | code, we haven't packed into Shcaml yet, so we need to tell 16 | pa_linetype.ml to leave off the leading Shcaml. 17 | -------------------------------------------------------------------------------- /doc/dot/style.css: -------------------------------------------------------------------------------- 1 | body { 2 | margin: 3em 10%; 3 | color: black; 4 | background-color: white; 5 | } 6 | 7 | br { 8 | display: none; 9 | } 10 | code br, a+br { 11 | display: block; 12 | } 13 | 14 | hr { 15 | background-color: #484; 16 | border: 1px solid #8a8; 17 | height: 8px; 18 | width: 8px; 19 | margin: 1em auto; 20 | } 21 | 22 | h1, h2, h3, h4, h5, h6 { 23 | margin-top: 1em; 24 | margin-bottom: 1em; 25 | padding: 0; 26 | font-weight: normal; 27 | } 28 | h1 { margin-top: 0.25em; } 29 | h1 { color: #060; } 30 | h2 { color: #060; } 31 | h3 { color: #090; } 32 | h4 { color: #0a0; } 33 | h5 { color: #3c3; font-style: italic; } 34 | h6 { color: #000; text-decoration: underline; } 35 | 36 | h1 { 37 | font-size : 2em; 38 | letter-spacing: 1px; 39 | text-align: center; 40 | } 41 | h2 { 42 | font-size : 1.44em; 43 | text-align: center; 44 | } 45 | 46 | h3 { font-size: 1.3em; } 47 | h4 { font-size: 1.15em; } 48 | h5 { font-size: 1em; } 49 | h6 { font-size: 1em; } 50 | 51 | div.h7 div.h8 div.h9 { 52 | /* not used */ 53 | } 54 | 55 | .navbar { 56 | text-align: right; 57 | } 58 | .navbar a:before { content: "["; } 59 | .navbar a:after { content: "]"; } 60 | 61 | p { 62 | margin: 1em 0; 63 | padding: 0; 64 | } 65 | 66 | a { 67 | color: #33f; 68 | text-decoration: none; 69 | background-color: #ffc; 70 | } 71 | h1 a, .navbar a { 72 | background-color: transparent; 73 | } 74 | 75 | a:hover { 76 | background-color: #ff0; 77 | } 78 | a:active, a:active * { 79 | color: white !important; 80 | background-color: #009; 81 | } 82 | 83 | .info { 84 | width: 75%; 85 | margin: 0.75em 1em 1.5em 1em; 86 | } 87 | 88 | .keyword { color: #c00 } 89 | .keywordsign { color: #900; } 90 | .comment { color :#990 } 91 | .constructor { color: #009 } 92 | .type { color : #093 } 93 | .string { color : #900; } 94 | .warning { color: #c00; font-weight: bold; } 95 | .param_info { margin-top: 4px; margin-left : 3em; margin-right : 3em } 96 | .code { color : #459; } 97 | 98 | .indextable { 99 | margin: 1em; 100 | border-style: hidden; 101 | } 102 | .indextable td { 103 | text-align: left; 104 | vertical-align: top; 105 | padding: 0.25em; 106 | margin: 0; 107 | } 108 | .indextable .info { 109 | margin: 0; 110 | } 111 | 112 | .typetable { 113 | border-style: hidden; 114 | } 115 | .typetable td { 116 | margin: 0; 117 | padding: .25em .5em 0 0; 118 | } 119 | 120 | table tr td b { 121 | font-weight: normal; 122 | font-style: italic; 123 | display: block; 124 | margin-top: .5em; 125 | } 126 | table tr td .info b { 127 | font-weight: bold; 128 | font-style: normal; 129 | display: inline; 130 | margin-top: 0; 131 | } 132 | .paramstable { 133 | margin: 2em 0 1em -5em; 134 | border-style: hidden; 135 | } 136 | 137 | td.typefieldcomment { 138 | font-size: .95em; 139 | font-style: italic; 140 | } 141 | 142 | pre+pre { 143 | margin-top: -.75em; 144 | color: #666; 145 | } 146 | pre+pre+pre { 147 | margin-top: -1.25em; 148 | } 149 | 150 | div.sig_block { 151 | margin-left: 2em 152 | } 153 | 154 | .superscript { 155 | /* Not used */ 156 | /* font-size: 4; */ 157 | } 158 | .subscript { 159 | /* Not used */ 160 | /* font-size: 4; */ 161 | } 162 | -------------------------------------------------------------------------------- /doc/make-index.sed: -------------------------------------------------------------------------------- 1 | # This script is meant to be run with sed -nf 2 | 3 | # This takes the styled script tutorial doc/tutorial.ml (which is 4 | # Ocaml-parsable) and generates doc/INDEX for use as the HTML 5 | # documentation index. 6 | 7 | :start 8 | /^[[:space:]]*(\*\**[[:space:]]*$/bcomment0 9 | /^[[:space:]]*$/{ 10 | n 11 | bstart 12 | } 13 | bcode0 14 | 15 | :comment0 16 | n 17 | /^[[:space:]]*$/bcomment0 18 | :comment1 19 | /^> /bresponse0 20 | /^[[:space:]]*\*\**)[[:space:]]*$/{ 21 | n 22 | bstart 23 | } 24 | p 25 | n 26 | bcomment1 27 | 28 | :response0 29 | s/^> /{v / 30 | h 31 | :response1 32 | n 33 | /^> /{ 34 | s/^> // 35 | s/^\([[:space:]]*\)-/\1-/ 36 | H 37 | bresponse1 38 | } 39 | x 40 | s/$/\ 41 | v}/ 42 | p 43 | x 44 | bcomment1 45 | 46 | :code0 47 | s/^/{[# / 48 | h 49 | :code1 50 | n 51 | /^[[:space:]]*(\*\**[[:space:]]*$/{ 52 | g 53 | s/[[:space:]]*$/]}/ 54 | p 55 | bcomment0 56 | } 57 | s/^/ / 58 | H 59 | bcode1 60 | -------------------------------------------------------------------------------- /doc/postprocess.ml: -------------------------------------------------------------------------------- 1 | open Soup 2 | 3 | let fix_include_with file signame to_add = 4 | let soup = read_file file |> parse in 5 | let enclosing_pre = 6 | soup $$ "pre > span.keyword" 7 | |> filter (fun n -> R.leaf_text n = "include") 8 | |> map R.parent 9 | |> filter (fun n -> (n $ "a" |> R.leaf_text) = signame) 10 | |> R.first in 11 | (* make this function idempotent *) 12 | enclosing_pre $ "a" $$ "~ *" |> iter delete; 13 | append_child enclosing_pre (parse to_add); 14 | write_file file (to_string soup) 15 | 16 | let _ = 17 | Unix.chdir "doc/api.docdir"; 18 | 19 | fix_include_with "Fitting.html" "FittingSig.S" 20 | {| 21 | with type initial = LineShtream.initial 22 | and type 'a elem = 'a LineShtream.elem 23 | and type 'a shtream = 'a LineShtream.t 24 | and type 'a coshtream = 'a LineShtream.co_t|}; 25 | 26 | fix_include_with "LineShtream.html" "AnyShtream.S" 27 | {| with module Elem = LineElem|}; 28 | 29 | fix_include_with "StringShtream.html" "AnyShtream.S" 30 | {| with module Elem = StringElem|}; 31 | 32 | fix_include_with "AnyShtream.S.html" "Shtream.COMMON" 33 | {| 34 | with type 'a t = 'a Shtream.t 35 | and type 'a co_t = 'a Shtream.co_t|}; 36 | 37 | fix_include_with "Shtream.html" "Shtream.COMMON" 38 | {| 39 | with type 'a t := 'a t 40 | and type 'a co_t := 'a co_t|} 41 | -------------------------------------------------------------------------------- /doc/style.css: -------------------------------------------------------------------------------- 1 | /* A style for ocamldoc. Daniel C. Buenzli */ 2 | 3 | /* Reset a few things. */ 4 | html,body,div,span,applet,object,iframe,h1,h2,h3,h4,h5,h6,p,blockquote,pre, 5 | a,abbr,acronym,address,big,cite,code,del,dfn,em,font,img,ins,kbd,q,s,samp, 6 | small,strike,strong,sub,sup,tt,var,b,u,i,center,dl,dt,dd,ol,ul,li,fieldset, 7 | form,label,legend,table,caption,tbody,tfoot,thead,tr,th,td 8 | { margin: 0; padding: 0; border: 0 none; outline: 0; font-size: 100%; 9 | font-weight: inherit; font-style:inherit; font-family:inherit; 10 | line-height: inherit; vertical-align: baseline; text-align:inherit; 11 | color:inherit; background: transparent; } 12 | 13 | table { border-collapse: collapse; border-spacing: 0; } 14 | 15 | /* Basic page layout */ 16 | 17 | body { font: normal 12pt/1.375em helvetica, arial, sans-serif; text-align:left; 18 | margin: 1.375em 10%; min-width: 40ex; max-width: 72ex; 19 | color: black; background: #FAFAFA /* url(line-height-22.gif) */; } 20 | 21 | b { font-weight: bold } 22 | em { font-style: italic } 23 | 24 | tt, code, pre { font-family: WorkAroundWebKitAndMozilla, monospace; 25 | font-size: 1em; } 26 | pre code { font-size : inherit; } 27 | .verbatim { margin-bottom:1.375em /* after code example we introduce space. */ } 28 | 29 | pre { padding: 5px; } 30 | /* code.code, */ pre.codepre, pre.verbatim { background-color: #E9E9E9; border-radius: 3px; } 31 | code.code { font-size: 95%; padding: 0.1em 0.2em; } 32 | pre.codepre code.code { padding: 0; } 33 | 34 | .superscript,.subscript 35 | { font-size : 0.813em; line-height:0; margin-left:0.4ex;} 36 | .superscript { vertical-align: super; } 37 | .subscript { vertical-align: sub; } 38 | 39 | /* ocamldoc markup workaround hacks */ 40 | 41 | 42 | 43 | hr, hr + br, div + br, center + br, span + br, ul + br, ol + br, pre + br, 44 | h2 + br, h3 + br, h4 + br, h5 + br, h6 + br 45 | { display: none } /* annoying */ 46 | 47 | div.info + br { display:inline } 48 | 49 | .codepre br + br { display: none } 50 | h1 + pre { margin-bottom:1.375em} /* Toplevel module description */ 51 | 52 | /* Sections and document divisions */ 53 | 54 | /* .navbar { margin-bottom: -1.375em } */ 55 | h1 { font-weight: bold; font-size: 1.7em; /* margin-top:1.833em; */ 56 | margin-top:0.917em; padding-top:0.875em; 57 | border-top-style:solid; border-width:1px; border-color:#AAA; } 58 | h2 { font-weight: bold; font-size: 1.313em; margin-top: 1.048em } 59 | h3 { font-weight: bold; font-size: 1.125em; margin-top: 1.222em } 60 | h4 { font-weight: bold; font-size: 1em; margin-top: 1.375em} 61 | h5 { font-style: italic; } 62 | 63 | /* Used by OCaml's own library documentation. */ 64 | h6 { font-weight: bold; font-size: 1.125em; margin-top: 1.222em } 65 | .h7 { font-weight: bold; font-size: 1em; margin-top: 1.375em } 66 | 67 | p { margin-top: 1.375em } 68 | pre { margin-top: 1.375em } 69 | pre.codepre + * { margin-top: 1.375 } /* uhhhh */ 70 | pre.codepre + pre.verbatim { margin-top: 0 } 71 | .info, .param_info { margin: 0.1em 0em -0.458em 2em;}/* Description of types values etc. */ 72 | .variantinfo { margin: 0.1em 4em 1em 2em;} 73 | td .info { margin:0; padding:0; margin-left: 2em;} /* Description in indexes */ 74 | .info.module.top { margin-bottom: 1.375em; } 75 | 76 | ul, ol { margin-top:0.688em; padding-bottom:0.687em; 77 | list-style-position:outside} 78 | ul + p, ol + p { margin-top: 0em } 79 | ul { list-style-type: square } 80 | 81 | 82 | /* h2 + ul, h3 + ul, p + ul { } */ 83 | ul > li { margin-left: 1.375em; } 84 | ol > li { margin-left: 1.7em; } 85 | /* Links */ 86 | 87 | a, a:link, a:visited, a:active, a:hover { color : #00B; text-decoration: none } 88 | a:hover { text-decoration : underline } 89 | *:target {background-color: #FFFF99;} /* anchor highlight */ 90 | 91 | /* Code */ 92 | 93 | .keyword { font-weight: bold; color : darkred } 94 | .pipe { margin-right: 0.3em; } 95 | .comment { color : red } 96 | .constructor { color : green } 97 | .string { color : brown } 98 | .warning { color : red ; font-weight : bold } 99 | .typefieldcomment { padding-bottom: 0.7em; } 100 | .varianttable td:nth-child(n+2) { width: 100%; } 101 | 102 | /* Functors */ 103 | 104 | .paramstable { border-style : hidden ; padding-bottom:1.375em} 105 | .paramstable code { margin-left: 1ex; margin-right: 1ex } 106 | .sig_block {margin-left: 1em} 107 | 108 | /* Images */ 109 | 110 | img { margin-top: 1.375em; display:block } 111 | li img { margin-top: 0em; } 112 | -------------------------------------------------------------------------------- /examples/amb.ml: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env ocamlscript 2 | 3 | (* This script demonstrates how Shcaml can be used to implement the AMB 4 | * operator -- it runs two processes in the background, and when one 5 | * completes, it kills the other. *) 6 | 7 | Ocaml.packs := [ "shcaml" ] 8 | -- 9 | 10 | open Shcaml 11 | open Fitting 12 | open Util 13 | 14 | let rec bg_list commands kont = 15 | match commands with 16 | | [] -> kont [] 17 | | x :: xs -> command x ^&= fun proc -> 18 | bg_list xs @@ fun procs -> 19 | kont (proc :: procs) 20 | 21 | let main args = ignore @@ run begin 22 | bg_list args @@ fun procs -> 23 | ignore @@ Proc.wait_any procs; 24 | List.iter (Proc.kill ~raise:false 9) procs; 25 | yield (Proc.WEXITED 0) 26 | end 27 | 28 | (* Another example (without the recursion). *) 29 | let two_sleeps () = run begin 30 | command "sleep 1; echo a" ^&= fun a -> 31 | command "sleep 1; echo b" ^&= fun b -> 32 | Proc.kill ~raise:false 9 33 | (if a == Proc.wait_any [a; b] then b else a); 34 | yield (Proc.WEXITED 0) 35 | end 36 | 37 | if not !Sys.interactive then 38 | main ((Flags.go "") # strings "") 39 | -------------------------------------------------------------------------------- /examples/amb.sh: -------------------------------------------------------------------------------- 1 | #!/bin/sh 2 | 3 | # This script attempts to start several processes and then kill the rest 4 | # when one finishes. We haven't figured out how to write it, though. 5 | # See scripts/amb.ml for a version that works. 6 | 7 | stop= 8 | pids= 9 | 10 | trap "stop=please" USR1 11 | 12 | for i; do 13 | sh -c "$i; kill -USR1 $$ 2>/dev/null" & 14 | pids="$pids $!" 15 | done 16 | 17 | echo $pids 18 | 19 | trap " 20 | ps; 21 | for pid in $pids; do 22 | kill -INT -\$pid; 23 | done; 24 | ps; 25 | exit 0 26 | " USR1 27 | 28 | if [ -n "$stop" ]; then 29 | kill -USR1 $$ 30 | fi 31 | 32 | wait 33 | -------------------------------------------------------------------------------- /examples/args.ml: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env ocaml 2 | 3 | #use "topfind";; 4 | #require "shcaml.top";; 5 | 6 | open Printf;; 7 | 8 | let lookup = Flags.go "-a --bee -c --dog=" in 9 | 10 | printf "Option -a is %b\n" (lookup#bool "-a"); 11 | printf "Option --bee is %b\n" (lookup#bool "--bee"); 12 | 13 | printf "Option -c is %s\n" (lookup#string ~default:"" "-c"); 14 | printf "Option --dog is %d\n" (lookup#int ~default:(-1) "--dog"); 15 | 16 | printf "All -c are:\n"; 17 | List.iter print_endline (lookup#strings "-c"); 18 | print_newline (); 19 | 20 | printf "All --dog are:\n"; 21 | List.iter (fun n -> print_endline (string_of_int n)) 22 | (lookup#ints "--dog"); 23 | print_newline (); 24 | 25 | printf "Trying to lookup string --dogs:\n"; 26 | List.iter print_endline (lookup#strings "--dog"); 27 | print_newline (); 28 | 29 | printf "Other arguments are:\n"; 30 | List.iter print_endline (lookup#strings ""); 31 | print_newline (); 32 | 33 | printf "Finally, usage:\n"; 34 | lookup#usage 35 | 36 | -------------------------------------------------------------------------------- /examples/curl-amb.ml: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env ocaml 2 | 3 | #use "topfind";; 4 | #require "shcaml";; 5 | 6 | open Shcaml 7 | open Fitting 8 | open Channel.Dup 9 | open Util 10 | open UsrBin 11 | 12 | let rm = program "rm" 13 | let mv src dest = program "mv" [src; dest] 14 | 15 | let curl url file = program "curl" [url] -| to_file file 16 | 17 | let curl2 url1 url2 file = 18 | let file1 = file ^ ".1" in 19 | let file2 = file ^ ".2" in 20 | curl url1 file1 ^&= fun proc1 -> 21 | curl url2 file2 ^&= fun proc2 -> 22 | let winner = Proc.wait_any [proc1; proc2] in 23 | if winner == proc1 then begin 24 | Proc.kill ~raise:false Sys.sigint proc2; 25 | rm [file2] ^>> 26 | mv file1 file 27 | end else begin 28 | Proc.kill ~raise:false Sys.sigint proc1; 29 | rm [file1] ^>> 30 | mv file2 file 31 | end ^>> 32 | yield (Proc.wait winner) 33 | 34 | let curl2 url1 url2 file = 35 | let file1 = file ^ ".1" in 36 | let file2 = file ^ ".2" in 37 | curl url1 file1 ^&= fun proc1 -> 38 | curl url2 file2 ^&= fun proc2 -> 39 | let winner = Proc.wait_any [proc1; proc2] in 40 | match Proc.wait winner with 41 | | Proc.WEXITED 0 when winner == proc1 -> 42 | Proc.kill ~raise:false Sys.sigint proc2; 43 | rm [file2] ^>> 44 | mv file1 file 45 | | Proc.WEXITED 0 when winner == proc1 -> 46 | Proc.kill ~raise:false Sys.sigint proc1; 47 | rm [file1] ^>> 48 | mv file2 file 49 | | _ when winner = proc1 -> 50 | let status = Proc.wait proc2 in 51 | rm [file1] ^>> 52 | mv file2 file ^>> 53 | yield status 54 | | _ -> 55 | let status = Proc.wait proc1 in 56 | rm [file2] ^>> 57 | mv file1 file ^>> 58 | yield status 59 | 60 | let amb act1 act2 kont = 61 | act1 ^&= fun proc1 -> 62 | act2 ^&= fun proc2 -> 63 | let winner = Proc.wait_any [proc1; proc2] in 64 | match Proc.wait winner with 65 | | Proc.WEXITED 0 as status when winner == proc1 -> 66 | Proc.kill ~raise:false Sys.sigint proc2; 67 | kont 1 status 68 | | Proc.WEXITED 0 as status -> 69 | Proc.kill ~raise:false Sys.sigint proc1; 70 | kont 2 status 71 | | _ when winner == proc1 -> 72 | kont 2 (Proc.wait proc2) 73 | | _ -> 74 | kont 1 (Proc.wait proc1) 75 | 76 | let curl2 url1 url2 file = 77 | let file1 = file ^ ".1" in 78 | let file2 = file ^ ".2" in 79 | amb (curl url1 file1) (curl url2 file2) @@ fun winner status -> 80 | if winner = 1 then 81 | ~>>[ rm [file2]; mv file1 file; yield status ] 82 | else 83 | ~>>[ rm [file1]; mv file2 file; yield status ] 84 | 85 | (**) 86 | 87 | let shells = 88 | from_file "/etc/passwd" -| 89 | Adaptor.Passwd.fitting () -| 90 | cut Line.Passwd.shell -| 91 | sort () -| 92 | uniq () 93 | 94 | (**) 95 | 96 | let passwd_to_csv () = 97 | Shtream.iter (Line.Delim.output stdout) @@ 98 | Shtream.map 99 | (fun line -> Line.Delim.set_options Delimited.default_options @@ 100 | Line.Delim.create [| Line.Passwd.name line; 101 | Line.Passwd.gecos line |] line) @@ 102 | Adaptor.Passwd.adaptor @@ 103 | LineShtream.of_file "/etc/passwd" 104 | 105 | ;; 106 | passwd_to_csv () 107 | -------------------------------------------------------------------------------- /examples/daedelus.ml: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env ocaml 2 | 3 | #use "topfind";; 4 | #require "shcaml.top";; 5 | 6 | open Proc 7 | 8 | let isn't_running prog = 9 | Shtream.is_empty @@ 10 | run_source begin 11 | ps () -| 12 | grep (Reader.starts_with prog % Line.Ps.command) 13 | end 14 | 15 | let main prog args delay = 16 | if isn't_running prog && not (Test.d (backquote "date +%Y-%m-%d")) then 17 | let proc = vfork_program prog args in 18 | sleep delay; 19 | match status_of_proc proc with 20 | | None -> () 21 | | Some n -> 22 | Printf.eprintf ("%s stubbornly refuses to run\n%!") prog 23 | ;; 24 | 25 | let lookup = Flags.go ~usage:"[--wait SECONDS] [--] PROGRAM [ARGS...]" 26 | "--wait " in 27 | let delay = lookup # int ~default:2 "--wait" in 28 | match lookup # strings "" with 29 | | prog::args -> 30 | main prog args delay 31 | | _ -> 32 | lookup # usage; 33 | exit 1 34 | -------------------------------------------------------------------------------- /examples/downsample.ml: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env ocaml 2 | 3 | #use "topfind";; 4 | #require "shcaml.top";; 5 | 6 | (** This is a quick one-shot to downsample all the mp3s in the current 7 | directory into a subdirectory called lofi/. I actually do this 8 | all the time for audiobooks I'm going to listen to on my phone, 9 | but type it in by hand. In shell, it's: 10 | 11 | for i in *mp3; do lame --preset sw "$i" lofi/"$i"; done 12 | 13 | This is a 14 | *) 15 | 16 | let main () = 17 | let files = 18 | run_source (command "ls" -| 19 | grep (Reader.ends_with ".mp3" % Line.show)) in 20 | mkpath "lofi"; 21 | Shtream.iter (fun l -> 22 | let name = "'" ^ Line.show l ^ "'" in 23 | ignore @@ 24 | Proc.system 25 | ("lame --preset sw " ^ name ^ " lofi/" ^ name)) files 26 | 27 | in 28 | main () 29 | -------------------------------------------------------------------------------- /examples/init-git-svn.sh: -------------------------------------------------------------------------------- 1 | #!/bin/sh 2 | 3 | usage () { 4 | exec 1>&2 5 | echo "" 6 | echo "Usage: $0 -[Ff]" 7 | echo "Configure a git work tree to use git-svn to pull from the" 8 | echo "Caml-Shcaml SVN repository." 9 | echo "" 10 | echo "Options" 11 | echo " -f fetch SVN metadata" 12 | echo " -F don't fetch SVN metadata" 13 | echo "" 14 | } 15 | 16 | fetch= 17 | 18 | for arg; do 19 | case "$arg" in 20 | -f) fetch=yes 21 | ;; 22 | -F) fetch=no 23 | ;; 24 | -h|--help) 25 | usage 26 | exit 27 | ;; 28 | *) echo "$0: unknown argument: \`$arg'" >&2 29 | usage 30 | exit 1 31 | ;; 32 | esac 33 | done 34 | 35 | if [ -z "$fetch" ]; then 36 | echo "$0: no argument provided" >&2 37 | usage 38 | exit 1 39 | fi 40 | 41 | # Tell git to git the remote SVN trunk, and then git it: 42 | git config --add remote.origin.fetch '+refs/remotes/trunk:refs/remotes/trunk' 43 | git fetch origin 44 | 45 | # Initialize git-svn. It will use the trunk that we already gitted. 46 | git svn init -t tags -b branches -T trunks/shcaml \ 47 | svn+ssh://osprepo.janestcapital.com/home/svn/repos/osp/2007/caml-shcaml 48 | 49 | # Optionally fetch: 50 | if [ "$fetch" = yes ]; then 51 | git svn fetch 52 | fi 53 | 54 | -------------------------------------------------------------------------------- /examples/notify.ml: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env ocaml 2 | 3 | #use "topfind";; 4 | #require "shcaml.top";; 5 | 6 | open Channel 7 | open Shtream 8 | open Util 9 | 10 | let gettime args = 11 | Int64.of_string @@ 12 | backquote ("date -d " ^ args ^ " +%s") 13 | 14 | let poor_man's_daemonize () = 15 | maybe (Proc.fork ()) id (fun _ -> exit 0) 16 | 17 | let main time = 18 | let now = gettime "now" in 19 | let later = gettime time in 20 | let delay = Int64.to_int (Int64.sub later now) in 21 | if delay < 0 22 | then prerr_endline "Can't remind you of a date in the past" 23 | else begin 24 | poor_man's_daemonize (); 25 | mov2 (1 %>/ open_command_out "xmessage -file -"); 26 | sleep delay; 27 | print_endline 28 | (if Array.length Sys.argv < 3 29 | then "Consider yourself notified" 30 | else Sys.argv.(2)) 31 | end 32 | 33 | ;; 34 | if Array.length Sys.argv < 2 then begin 35 | Printf.eprintf "Usage: %s DELAY [MESSAGE]\n" Sys.argv.(0); 36 | exit 2 37 | end else 38 | main Sys.argv.(1) 39 | -------------------------------------------------------------------------------- /examples/pgrep.ml: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env ocaml 2 | 3 | (* Quick reimplementation of pgrep(1). *) 4 | 5 | #use "topfind";; 6 | #require "shcaml.top";; 7 | 8 | let pgrep pat = ignore @@ run begin 9 | ps () -| 10 | grep (Reader.starts_with pat % Line.Ps.command) -| 11 | cut (string_of_int % Line.Ps.pid) 12 | end 13 | 14 | ;; 15 | if Array.length Sys.argv > 1 then 16 | pgrep Sys.argv.(1) 17 | else 18 | Printf.eprintf "Usage: %s PROGRAM\n" Sys.argv.(0) 19 | -------------------------------------------------------------------------------- /examples/ppool.ml: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env ocaml 2 | 3 | (* Keep a given number of processes running simultaneously *) 4 | 5 | #use "topfind";; 6 | #require "shcaml.top";; 7 | 8 | let args = Flags.go ~usage:"-n NPROCS COMMAND ARGS..." 9 | "-n ";; 10 | let n = args # int "-n";; 11 | 12 | match args # strings "" with 13 | | prog :: args -> 14 | let reader = StringShtream.elem_reader 15 | (Reader.make (`Set " \r\n\t")) in 16 | let each running next_proc = 17 | let running = 18 | if List.length running < n 19 | then running 20 | else List.filter ((!=) @@ Proc.wait_any running) running in 21 | let proc = fst @@ Channel.open_program ~dups:[0 %<* `Null] 22 | prog (args @ [next_proc]) in 23 | print_endline (string_of_int (Proc.pid_of_proc proc)); 24 | proc :: running in 25 | let shtream = StringShtream.of_channel ~reader stdin in 26 | ignore (Shtream.fold_left each [] shtream) 27 | | _ -> 28 | Channel.dup2 ( 1 %>& 2 ); 29 | args # usage; 30 | exit 2 31 | -------------------------------------------------------------------------------- /examples/shmencode.ml: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env ocamlscript 2 | Ocaml.packs := [ "shcaml" ] 3 | -- 4 | 5 | open Shcaml 6 | open Fitting 7 | open Adaptor 8 | open UsrBin 9 | open Reader 10 | open Printf 11 | open Channel.Dup 12 | 13 | (* Individual track data. *) 14 | type track = { 15 | index: int; 16 | title: string; 17 | wav: string; 18 | mp3: string; 19 | } 20 | 21 | let make_track index title = { 22 | index = index; 23 | title = title; 24 | wav = sprintf "%02d %s.wav" index title; 25 | mp3 = sprintf "%02d %s.mp3" index title; 26 | } 27 | 28 | module CddbID : sig 29 | val discid : (int * int) list -> string 30 | end = struct 31 | open Int32 32 | open List 33 | 34 | let ((+), (%), (/), (<<<), (|||)) = 35 | (add, rem, div, shift_left, logor) 36 | 37 | let ten = of_int 10 38 | let fps = of_int 75 39 | 40 | let sum_digits = 41 | let rec loop acc n = if n = zero then acc else loop (acc + n % ten) (n / ten) in 42 | loop zero 43 | 44 | let discid track_list = 45 | let lengths = map (fun (x,_) -> of_int x) track_list in 46 | let offsets = map (fun (_,y) -> of_int y) track_list in 47 | let ntracks = of_int (length lengths) in 48 | let n = fold_left (fun x y -> x + sum_digits (y / fps + of_int 2)) zero offsets in 49 | let t = fold_left (+) zero lengths / fps in 50 | let id = (n % of_int 0xff <<< 24) ||| (t <<< 8) ||| ntracks in 51 | sprintf "%08lx" id 52 | end 53 | 54 | (* Getting the disc ID *) 55 | module CdParanoia = Delim.Make_names(struct 56 | let options = { Delimited.default_options with 57 | Delimited.field_sep = ' ' } 58 | let names = [ "track"; "length"; "length-msh"; 59 | "begin"; "begin-msh"; "copy"; 60 | "pre"; "ch" ] 61 | end) 62 | 63 | let get_track_data () = run_list begin 64 | command "cdparanoia -Q 2>&1" 65 | -| grep_string (starts_with " ") 66 | -| CdParanoia.fitting () 67 | -| sed (fun line -> (Line.Delim.get_int "length" line, 68 | Line.Delim.get_int "begin" line)) 69 | end 70 | 71 | let get_discid () = CddbID.discid (get_track_data ()) 72 | 73 | 74 | (* Getting the track info *) 75 | let cddb_request discid = 76 | "http://freedb.freedb.org/~cddb/cddb.cgi" ^ 77 | "?cmd=cddb+read+rock+" ^ discid ^ "&hello=" ^ 78 | backquote "whoami" ^ "+" ^ backquote "hostname" ^ 79 | "+shmendcode+0.1b&proto=6" 80 | 81 | let curl url = program "curl" ["-s"; url] 82 | 83 | let parse_album value = 84 | match Pcre.split ~pat:" / " ~max:2 value with 85 | | [ artist; album ] -> ["--ta"; artist; "--tl"; album] 86 | | _ -> ["--ta"; value; "--tl"; value] 87 | 88 | let parse_track key value tracks = 89 | try Scanf.sscanf key "TTITLE%d" 90 | (fun n -> make_track (n + 1) value :: tracks) 91 | with _ -> tracks 92 | 93 | let parse_cddb_line (tracks, album) line = 94 | let module KV = Line.Key_value in 95 | match KV.key line with 96 | | "DYEAR" -> tracks, ["--ty"; KV.value line] @ album 97 | | "DGENRE" -> tracks, ["--tg"; KV.value line] @ album 98 | | "DTITLE" -> tracks, parse_album (KV.value line) 99 | @ album 100 | | key -> parse_track key (KV.value line) tracks, album 101 | 102 | let get_cddb discid = 103 | let (tracks, album_tags) = 104 | Shtream.fold_left parse_cddb_line ([], []) 105 | (run_source begin 106 | curl (cddb_request discid) 107 | -| Key_value.fitting ~quiet:true () 108 | end) in 109 | (List.rev tracks, album_tags) 110 | 111 | (* Ripping and encoding. *) 112 | let rip track = 113 | program "cdparanoia" 114 | ["--"; string_of_int track.index; track.wav] 115 | />/ [ 2 %>* `Null; 1 %>& 2 ] 116 | 117 | let encode album_tags track = 118 | program "lame" 119 | (album_tags @ 120 | ["--tn"; string_of_int track.index; 121 | "--tt"; track.title; "--quiet"; 122 | track.wav; track.mp3]) 123 | &&^ program "rm" [track.wav] 124 | 125 | let build_dag (tracks, album) = 126 | let each (mp3s, prev) track = 127 | let wav = DepDAG.make ~prio:1 (fun _ -> 128 | printf "Ripping %s\n%!" track.wav; 129 | run_bg (rip track) 130 | ) prev in 131 | let mp3 = DepDAG.make ~prio:2 (fun _ -> 132 | printf "Encoding %s\n%!" track.mp3; 133 | run_bg (encode album track) 134 | ) [wav] in 135 | (mp3::mp3s, [wav]) in 136 | let mp3s, _ = List.fold_left each ([], []) tracks in 137 | DepDAG.make_par mp3s 138 | 139 | let main () = 140 | let opts = Flags.go "-N " in 141 | let n = opts#int ~default:2 "-N" in 142 | let discinfo = get_cddb (get_discid ()) in 143 | DepDAG.run ~n (build_dag discinfo) 144 | 145 | ;; 146 | main () 147 | -------------------------------------------------------------------------------- /examples/timeout.ml: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env ocaml 2 | 3 | #use "topfind";; 4 | #require "shcaml.top";; 5 | 6 | let usage = "[-s SECONDS] [COMMAND ARGS...]" 7 | let lookup = Flags.go ~usage "-s " 8 | let delay = lookup # int ~default:1 "-s" 9 | 10 | let to_run = 11 | match lookup # strings "" with 12 | | prog :: args -> program prog args 13 | | _ -> command "yes i am going to run forever" 14 | 15 | ;; 16 | run begin 17 | to_run ^&= fun proc -> 18 | sleep delay; 19 | Proc.kill ~raise:false Sys.sigint proc; 20 | yield (Proc.WEXITED 0) 21 | end 22 | -------------------------------------------------------------------------------- /examples/wait.ml: -------------------------------------------------------------------------------- 1 | #! /usr/bin/env ocamlscript 2 | Ocaml.packs := [ "shcaml" ] 3 | -- 4 | 5 | open Shcaml 6 | open Fitting 7 | 8 | let echo s = program "echo" [s];; 9 | 10 | run begin 11 | ( command "sleep 1" ^>> 12 | echo "b" ^>> 13 | command "sleep 1" ) ^&= function proc -> 14 | echo "a" ^>> 15 | caml (fun _ -> 16 | ignore (Proc.wait proc); 17 | echo "c" 18 | ) 19 | end 20 | -------------------------------------------------------------------------------- /examples/wait.sh: -------------------------------------------------------------------------------- 1 | #!/bin/sh 2 | 3 | ( 4 | sleep 1 5 | echo b 6 | sleep 1 7 | ) & 8 | PROC=$! 9 | echo a 10 | wait $PROC 11 | echo c -------------------------------------------------------------------------------- /lib/abort.ml: -------------------------------------------------------------------------------- 1 | open Util 2 | 3 | exception Abort of (unit -> unit) 4 | 5 | let abort_is_set = ref false 6 | 7 | let rec with_abort kont = 8 | let result = 9 | try Right (kont ()) with 10 | | Abort next -> Left next in 11 | match result with 12 | | Right r -> r 13 | | Left next -> with_abort 14 | (fun () -> 15 | try next (); exit 0 with 16 | | Abort _ as a -> raise a 17 | | e -> exit 2) 18 | 19 | let set_abort kont = 20 | if !abort_is_set 21 | then kont () 22 | else unwind_protect 23 | (fun () -> abort_is_set := true; 24 | with_abort kont) 25 | (fun () -> abort_is_set := false) 26 | 27 | let abort thunk = 28 | set_abort (fun () -> raise (Abort thunk)) 29 | -------------------------------------------------------------------------------- /lib/abort.mli: -------------------------------------------------------------------------------- 1 | (** Protocol to discard the current continuation and replace it 2 | * with a thunk. In short, [E\[ abort M \] -> M ()] 3 | * 4 | * Often we want to fork a child process with a limited task, after 5 | * which it should exit. The idea of {!Abort.abort} is that it enforces 6 | * that control does not escape the given thunk. Furthermore, calling 7 | * {!Abort.set_abort} high up the stack enables memory that is no longer 8 | * in use to be recovered on the next GC. (Obviously you don't want to 9 | * do this if you're about to exec, since you'll destroy copy-on-write 10 | * efficiency, but if you're going to fork and then stick around a 11 | * while, it might be worthwhile.) 12 | *) 13 | 14 | (** Abort the current continuation, replacing it with a thunk. 15 | * This function doesn't return. *) 16 | val abort : (unit -> unit) -> 'a 17 | 18 | (** Set the abort handler if none is set. Call this as soon as possible 19 | * in a program, so that the rest is in its dynamic extent, and then 20 | * {!Abort.abort} can throw control there. *) 21 | val set_abort : (unit -> 'a) -> 'a 22 | 23 | -------------------------------------------------------------------------------- /lib/anyShtream.ml: -------------------------------------------------------------------------------- 1 | (* vim: set ft=ocaml : *) 2 | open Util 3 | 4 | module type ELEM = sig 5 | type 'a elem 6 | type initial 7 | val reader : unit -> in_channel -> initial elem 8 | val of_string : unit -> string -> initial elem 9 | val string_of : unit -> 'a elem -> string 10 | end 11 | 12 | module type S = sig 13 | include Shtream.COMMON 14 | with type 'a t = 'a Shtream.t 15 | and type 'a co_t = 'a Shtream.co_t 16 | 17 | module Elem : ELEM 18 | 19 | type 'a elem = 'a Elem.elem 20 | type initial = Elem.initial 21 | 22 | val elem_reader : Reader.t -> (in_channel -> initial elem) 23 | val output : ?channel:out_channel -> 24 | ?init:('a elem -> string) -> 25 | ?term:('a elem -> string) -> 26 | ?show:('a elem -> string) -> 27 | 'a elem t -> 28 | unit 29 | val channel_of : ?procref:Channel.procref -> 30 | ?before:(unit -> unit) -> 31 | ?after:(unit -> unit) -> 32 | ?init:('a elem -> string) -> 33 | ?term:('a elem -> string) -> 34 | ?show:('a elem -> string) -> 35 | 'a elem t -> in_channel 36 | val string_list_of : ?show:('a elem -> string) -> 37 | 'a elem t -> string list 38 | val string_stream_of : ?show:('a elem -> string) -> 39 | 'a elem t -> string Stream.t 40 | val of_channel : ?reader:(in_channel -> initial elem) -> 41 | in_channel -> initial elem t 42 | val of_file : ?reader:(in_channel -> initial elem) -> 43 | string -> initial elem t 44 | val of_command : ?procref:Channel.procref -> 45 | ?dups:Channel.dup_spec -> 46 | ?reader:(in_channel -> initial elem) -> 47 | string -> 48 | initial elem t 49 | val of_program : ?procref:Channel.procref -> 50 | ?dups:Channel.dup_spec -> 51 | ?reader:(in_channel -> initial elem) -> 52 | ?path:bool -> string -> ?argv0:string -> string list -> 53 | initial elem t 54 | val of_thunk : ?procref:Channel.procref -> 55 | ?dups:Channel.dup_spec -> 56 | ?reader:(in_channel -> initial elem) -> 57 | (unit -> unit) -> 58 | initial elem t 59 | val of_string_list : ?parse:(string -> initial elem) -> 60 | string list -> initial elem t 61 | val of_string_stream : ?parse:(string -> initial elem) -> 62 | string Stream.t -> initial elem t 63 | end 64 | 65 | module Make (E : ELEM) : (S with module Elem = E) = struct 66 | include Shtream 67 | 68 | module Elem = E 69 | 70 | type 'a elem = 'a Elem.elem 71 | type initial = Elem.initial 72 | 73 | let elem_reader reader = 74 | let of_string = Elem.of_string () in 75 | fun c -> of_string (reader c).Reader.content 76 | 77 | let output ?(channel = stdout) 78 | ?(init = fun _ -> "") 79 | ?(term = fun _ -> "\n") 80 | ?(show = Elem.string_of ()) = 81 | iter (fun elt -> 82 | output_string channel (init elt); 83 | output_string channel (show elt); 84 | output_string channel (term elt); 85 | flush channel) 86 | 87 | let channel_of ?procref ?before ?after 88 | ?(init = fun _ -> "") 89 | ?(term = fun _ -> "\n") 90 | ?(show = Elem.string_of ()) = 91 | channel_of ?procref ?before ?after 92 | (fun elt -> 93 | print_string (init elt); 94 | print_string (show elt); 95 | print_string (term elt)) 96 | 97 | let string_list_of ?(show = Elem.string_of ()) = 98 | list_of % map show 99 | 100 | let string_stream_of ?(show = Elem.string_of ()) = 101 | stream_of % map show 102 | 103 | (* This little helper function either passes through the given reader, 104 | * or selects a default and indicates that the resulting shtream 105 | * should be susceptible to hints. *) 106 | let default_reader reader (kont : ?hint:(Reader.raw_line -> 'a) -> 'b) = 107 | match reader with 108 | | None -> let parse = Elem.of_string () in 109 | let hint r = parse r.Reader.content in 110 | kont ~hint (Elem.reader ()) 111 | | Some r -> kont r 112 | 113 | let of_channel ?reader = 114 | default_reader reader of_channel 115 | 116 | let of_file ?reader = 117 | default_reader reader of_file 118 | 119 | let of_command ?procref ?dups ?reader = 120 | default_reader reader (of_command ?procref ?dups) 121 | 122 | let of_program ?procref ?dups ?reader = 123 | default_reader reader (of_program ?procref ?dups) 124 | 125 | let of_thunk ?procref ?dups ?reader = 126 | default_reader reader (of_thunk ?procref ?dups) 127 | 128 | let of_string_list ?(parse = Elem.of_string ()) = map parse % of_list 129 | let of_string_stream ?(parse = Elem.of_string ()) = map parse % of_stream 130 | end 131 | -------------------------------------------------------------------------------- /lib/anyShtream.mli: -------------------------------------------------------------------------------- 1 | (* vim: set ft=ocaml : *) 2 | (** 3 | * Functor to create type-aware shtream modules. The base shtream 4 | * module {!Shtream} is indifferent to the element type. The functor 5 | * {!AnyShtream.Make}, on the other hand, produces a module with shtream 6 | * functions that know how read shtream from and write shtreams to 7 | * channels without a user-supplied reader or printer function. 8 | * 9 | * Modules {!LineShtream} and {!StringShtream} are both created using 10 | * this functor, though some values in {!LineShtream} are specialized 11 | * further. 12 | *) 13 | 14 | (** The input signature of the functor {!AnyShtream.Make}. *) 15 | module type ELEM = sig 16 | (** The element type may be polymorphic, in which case the conversion 17 | * of elements to strings must handle any element. The conversion 18 | * from strings (or reading from channels) is monomorphic, returning 19 | * shtream elements of a particular type. 20 | *) 21 | 22 | type 'a elem 23 | (** The element type for the resulting shtream module. This type is 24 | * parameterized so that a shtream module might handle a family of 25 | * types. The function {!string_of} needs handle ['a elem] for any 26 | * ['a]. *) 27 | type initial 28 | (** The parameter to {!elem} for values returned by conversions from 29 | * strings. That is, [initial elem] is the type of shtream elements when 30 | * first read from a string or channel. *) 31 | 32 | val reader : unit -> in_channel -> initial elem 33 | (** Make a reader of shtream elements. The reader may be stateful; 34 | * a new one will be instantiated for each shtream. *) 35 | val of_string : unit -> string -> initial elem 36 | (** Make a parser of shtream elements. The parser may be stateful; 37 | * a new one will be instantiated for each shtream. *) 38 | val string_of : unit -> 'a elem -> string 39 | (** Make a convertor of shtream elements to strings. The resulting 40 | * function may be stateful; a new one will be instantiated for 41 | * shtream output operation. *) 42 | end 43 | 44 | (** The output signature of the functor {!AnyShtream.Make}. 45 | * The shtream and coshtream types in the resulting module are 46 | * compatible with other applications of the functor and with {!Shtream}. 47 | * 48 | * When {!AnyShtream.Make} is applied to a structure [Elem] (having 49 | * signature {!ELEM}), the resulting module knows how to write 50 | * shtreams of type ['a Elem.elem Shtream.t] and read shtreams of type 51 | * [Elem.initial Elem.elem Shtream.t]. Functions in the resulting 52 | * module take several optional parameters whose defaults are 53 | * supplied by [Elem]: 54 | * - [?(reader : in_channel -> initial elem)] defaults to 55 | * [Elem.reader ()]. 56 | * - [?(parse : string -> initial elem)] defaults to [Elem.of_string ()]. 57 | * - [?(show : 'a elem -> string)] defaults to [Elem.string_of ()]. 58 | *) 59 | module type S = sig 60 | (** The result of {!AnyShtream.Make} contains all the type-indifferent 61 | * shtream operations from {!Shtream}. *) 62 | include Shtream.COMMON 63 | with type 'a t = 'a Shtream.t 64 | and type 'a co_t = 'a Shtream.co_t 65 | 66 | (** Access to the underlying element type and operations. *) 67 | module Elem : ELEM 68 | 69 | type 'a elem = 'a Elem.elem 70 | (** Alias for {!ELEM.elem} *) 71 | type initial = Elem.initial 72 | (** Alias for {!ELEM.initial} *) 73 | 74 | (** Construct an [initial elem] reader from a record reader. 75 | * Functions such as {!of_channel} and {!of_program} take a function 76 | * of the type returned here. 77 | *) 78 | val elem_reader : Reader.t -> (in_channel -> initial elem) 79 | 80 | (** Write the entire contents of a shtream on a channel. 81 | * For each element [x] of the shtream, it prints [init x], then 82 | * [show x], and then [term x] on the channel, and then flushes the 83 | * channel. 84 | * @param channel default = [stdout] 85 | * @param init default = [fun _ -> ""] 86 | * @param show default = [Elem.string_of ()] 87 | * @param term default = [fun _ -> "\n"] 88 | *) 89 | val output : ?channel:out_channel -> 90 | ?init:('a elem -> string) -> 91 | ?term:('a elem -> string) -> 92 | ?show:('a elem -> string) -> 93 | 'a elem t -> 94 | unit 95 | 96 | (** Construct an [in_channel] from the data in a 97 | * shtream. If forking a child is necessary (see 98 | * {!Shtream.channel_of}), then the optional 99 | * parameter [?before] (resp. [?after]) is called in the child 100 | * before (resp. after) printing the shtream; anything printed on 101 | * [stdout] by [?before] ([?after]) appears in the resultant 102 | * [in_channel] before (after) the shtream data. 103 | * 104 | * The remaining arguments are as for {!output}. 105 | *) 106 | val channel_of : ?procref:Channel.procref -> 107 | ?before:(unit -> unit) -> 108 | ?after:(unit -> unit) -> 109 | ?init:('a elem -> string) -> 110 | ?term:('a elem -> string) -> 111 | ?show:('a elem -> string) -> 112 | 'a elem t -> in_channel 113 | 114 | (** Convert a shtream to a list of strings, using [?show]. *) 115 | val string_list_of : ?show:('a elem -> string) -> 116 | 'a elem t -> string list 117 | 118 | (** Convert a shtream to a {i standard library} [Stream.t] of 119 | * strings, using [?show]. *) 120 | val string_stream_of : ?show:('a elem -> string) -> 121 | 'a elem t -> string Stream.t 122 | 123 | (** Read a shtream from a channel, using [?reader]. *) 124 | val of_channel : ?reader:(in_channel -> initial elem) -> 125 | in_channel -> initial elem t 126 | 127 | (** Read a shtream from a file, using [?reader]. *) 128 | val of_file : ?reader:(in_channel -> initial elem) -> 129 | string -> initial elem t 130 | 131 | (** Read a shtream from the output of a command, using [?reader]. 132 | * If [?procref] is given, stash the {!Proc.t}; if [?dups] 133 | * is given, perform the dups in the child process. *) 134 | val of_command : ?procref:Channel.procref -> 135 | ?dups:Channel.dup_spec -> 136 | ?reader:(in_channel -> initial elem) -> 137 | string -> 138 | initial elem t 139 | 140 | (** Read a shtream from the output of a process, using [?reader]. 141 | * If [?procref] is given, stash the {!Proc.t}; if [?dups] 142 | * is given, perform the dups in the child process. *) 143 | val of_program : ?procref:Channel.procref -> 144 | ?dups:Channel.dup_spec -> 145 | ?reader:(in_channel -> initial elem) -> 146 | ?path:bool -> string -> ?argv0:string -> string list -> 147 | initial elem t 148 | 149 | (** Read a shtream from the output of a thunk, using [?reader]. 150 | * If [?procref] is given, stash the {!Proc.t}; if [?dups] 151 | * is given, perform the dups in the child process. *) 152 | val of_thunk : ?procref:Channel.procref -> 153 | ?dups:Channel.dup_spec -> 154 | ?reader:(in_channel -> initial elem) -> 155 | (unit -> unit) -> 156 | initial elem t 157 | 158 | (** Construct a shtream from a list of strings, using [?parse]. *) 159 | val of_string_list : ?parse:(string -> initial elem) -> 160 | string list -> initial elem t 161 | 162 | (** Construct a shtream from a {i standard 163 | * library} [Stream.t] of strings, using [?parse]. *) 164 | val of_string_stream : ?parse:(string -> initial elem) -> 165 | string Stream.t -> initial elem t 166 | end 167 | 168 | (** Build a new shtream module. The {!ELEM} 169 | * parameter {!E} specifies how to read and print shtream elements. *) 170 | module Make(E : ELEM) : S with module Elem = E 171 | -------------------------------------------------------------------------------- /lib/channel.ml: -------------------------------------------------------------------------------- 1 | open Util 2 | 3 | type descr = Unix.file_descr 4 | 5 | type any_channel = [ `InChannel of in_channel 6 | | `OutChannel of out_channel ] 7 | 8 | type gen_in_channel = [ `InChannel of in_channel 9 | | `InDescr of descr 10 | | `InFd of int ] 11 | 12 | type gen_out_channel = [ `OutChannel of out_channel 13 | | `OutDescr of descr 14 | | `OutFd of int ] 15 | 16 | type gen_channel = [ gen_in_channel 17 | | gen_out_channel ] 18 | 19 | type dup_in_source = [ gen_in_channel 20 | | `Filename of string 21 | | `Close 22 | | `Null ] 23 | 24 | type dup_out_source = [ gen_out_channel 25 | | `Filename of string 26 | | `Close 27 | | `Null 28 | | `Filespec of string * clobber_spec ] 29 | and clobber_spec = [ `Clobber | `NoClobber | `Append | `AppendOnly ] 30 | 31 | type dup_source = [ dup_in_source | dup_out_source ] 32 | 33 | type dup_in_spec = (dup_in_source * gen_in_channel) list 34 | type dup_out_spec = (dup_out_source * gen_out_channel) list 35 | type dup_spec = (dup_source * gen_channel) list 36 | 37 | type pipe_spec = gen_channel list 38 | 39 | type procref = Proc.t option ref 40 | 41 | let clobber = ref `Clobber 42 | 43 | external descr_of_fd : int -> descr = "%identity" 44 | external fd_of_descr : descr -> int = "%identity" 45 | 46 | let descr_of_ic = Unix.descr_of_in_channel 47 | let descr_of_oc = Unix.descr_of_out_channel 48 | 49 | let descr_of_gen = function 50 | | `InDescr d | `OutDescr d -> d 51 | | `InFd n | `OutFd n -> descr_of_fd n 52 | | `InChannel c -> descr_of_ic c 53 | | `OutChannel c -> descr_of_oc c 54 | 55 | module InDisposal = Disposal.Make (struct 56 | type t = in_channel 57 | let equal = (==) 58 | let hash c = try Hashtbl.hash (descr_of_gen (`InChannel c)) 59 | with Sys_error("Bad file descriptor") -> 103 60 | let default = Pervasives.close_in 61 | end) 62 | 63 | module OutDisposal = Disposal.Make (struct 64 | type t = out_channel 65 | let equal = (==) 66 | let hash c = try Hashtbl.hash (descr_of_gen (`OutChannel c)) 67 | with Sys_error("Bad file descriptor") -> 103 68 | let default = Pervasives.close_out 69 | end) 70 | 71 | let null_in () = Pervasives.open_in "/dev/null" 72 | let null_out () = Pervasives.open_out "/dev/null" 73 | 74 | let close_in = InDisposal.dispose 75 | let close_out = OutDisposal.dispose 76 | 77 | let open_file_in = InDisposal.manage % Pervasives.open_in 78 | let open_file_out = OutDisposal.manage % Pervasives.open_out 79 | 80 | let close_gen = function 81 | | `InChannel c -> close_in c 82 | | `OutChannel c -> close_out c 83 | | gen -> Unix.close (descr_of_gen gen) 84 | 85 | let dup_in = function 86 | | `Filename n -> open_file_in n 87 | | `Close -> let c = open_file_in "/dev/null" in 88 | close_in c; c 89 | | `Null -> null_in () 90 | | #gen_in_channel as g 91 | -> InDisposal.manage @@ 92 | Unix.in_channel_of_descr @@ 93 | Unix.dup @@ descr_of_gen g 94 | 95 | let get_flags = function 96 | | `Clobber -> [Unix.O_WRONLY; Unix.O_CREAT; Unix.O_TRUNC] 97 | | `NoClobber -> [Unix.O_WRONLY; Unix.O_CREAT; Unix.O_TRUNC; Unix.O_EXCL] 98 | | `Append -> [Unix.O_WRONLY; Unix.O_CREAT; Unix.O_APPEND] 99 | | `AppendOnly -> [Unix.O_WRONLY; Unix.O_APPEND] 100 | 101 | let rec dup_out = function 102 | | `Filename s -> dup_out (`Filespec (s, !clobber)) 103 | | `Filespec (s, spec) 104 | -> let d = Unix.openfile s (get_flags spec) 0o666 in 105 | OutDisposal.manage (Unix.out_channel_of_descr d) 106 | | `Null -> null_out () 107 | | `Close -> let c = open_file_out "/dev/null" in 108 | close_out c; c 109 | | #gen_channel as g 110 | -> OutDisposal.manage @@ 111 | Unix.out_channel_of_descr @@ 112 | Unix.dup @@ descr_of_gen g 113 | 114 | let dup2 = 115 | let flush_in c = 116 | let d = descr_of_ic c in 117 | Unix.close d; 118 | try while true do ignore (input_char c) done 119 | with Sys_error _ -> () in 120 | let rec dup_any dir source dest = 121 | match dir, source with 122 | | `In, (#gen_in_channel as gen) 123 | | `Out, (#gen_out_channel as gen) 124 | -> Unix.dup2 (descr_of_gen gen) dest 125 | | _, `Close -> Unix.close dest 126 | | `In, (#dup_in_source as ds) 127 | -> let ic = dup_in ds in 128 | let descr = descr_of_ic ic in 129 | Unix.dup2 descr dest; 130 | if dest <> descr then close_in ic 131 | | `Out, (#dup_out_source as ds) 132 | -> let oc = dup_out ds in 133 | let descr = descr_of_oc oc in 134 | Unix.dup2 descr dest; 135 | if dest <> descr then close_out oc 136 | | _ -> raise (Invalid_argument "dup2") in 137 | fun (source, dest) -> match dest with 138 | | `OutChannel c -> flush c; 139 | dup_any `Out source (descr_of_oc c) 140 | | `InChannel c -> flush_in c; 141 | dup_any `In source (descr_of_ic c) 142 | | `OutFd n -> dup_any `Out source (descr_of_fd n) 143 | | `InFd n -> dup_any `In source (descr_of_fd n) 144 | | `OutDescr d -> dup_any `Out source d 145 | | `InDescr d -> dup_any `In source d 146 | 147 | let mov2 (source, dest) = 148 | match source with 149 | | #gen_channel as source 150 | when descr_of_gen dest <> descr_of_gen source 151 | -> dup2 ((source :> dup_source), dest); 152 | close_gen source 153 | | _ -> dup2 (source, dest) 154 | 155 | let with_dup (source, dest) thunk = 156 | let destd = descr_of_gen dest in 157 | let saved = option_of_exn (fun _ -> Unix.dup destd) in 158 | begin try 159 | maybe saved ignore Unix.set_close_on_exec; 160 | dup2 (source, dest) 161 | with e -> maybe saved ignore Unix.close; raise e end; 162 | unwind_protect thunk (fun _ -> 163 | match saved, dest with 164 | | None , _ -> close_gen dest 165 | | Some d, #gen_in_channel -> mov2 (`InDescr d, dest) 166 | | Some d, #gen_out_channel -> mov2 (`OutDescr d, dest) 167 | ) 168 | 169 | let rec with_dups dups thunk = match dups with 170 | | [] -> thunk () 171 | | x::xs -> with_dup x (fun _ -> with_dups xs thunk) 172 | 173 | let rec connect_child = 174 | let connect_in fd (ifd, ofd) = 175 | Unix.dup2 ifd fd; 176 | Unix.close ifd; 177 | Unix.close ofd in 178 | let connect_out fd (ifd, ofd) = 179 | Unix.dup2 ofd fd; 180 | Unix.close ifd; 181 | Unix.close ofd in 182 | function 183 | | `InDescr fd -> connect_in fd 184 | | `InFd n -> connect_in (descr_of_fd n) 185 | | `InChannel c -> connect_in (descr_of_ic c) 186 | | `OutDescr fd -> connect_out fd 187 | | `OutFd n -> connect_out (descr_of_fd n) 188 | | `OutChannel c -> connect_out (descr_of_oc c) 189 | 190 | let connect_parent = function 191 | | #gen_in_channel -> fun (ifd, ofd) -> 192 | Unix.close ifd; 193 | `OutChannel (OutDisposal.manage (Unix.out_channel_of_descr ofd)) 194 | | #gen_out_channel -> fun (ifd, ofd) -> 195 | Unix.close ofd; 196 | `InChannel (InDisposal.manage (Unix.in_channel_of_descr ifd)) 197 | 198 | let open_thunk ?(pipes=[]) ?(dups=[]) thunk = 199 | let ceci_n'est_pas_une_liste_des_pipes = 200 | List.map (Unix.pipe % ignore) pipes in 201 | let proc = Proc.spawn (fun _ -> 202 | List.iter2 connect_child pipes ceci_n'est_pas_une_liste_des_pipes; 203 | List.iter dup2 dups; 204 | thunk () 205 | ) in 206 | proc, List.map2 connect_parent pipes ceci_n'est_pas_une_liste_des_pipes 207 | 208 | let stash pid = function 209 | | None -> () 210 | | Some pr -> pr := Some pid 211 | 212 | let open_thunk_in ?procref ?dups thunk = 213 | match open_thunk ~pipes:[ `OutDescr Unix.stdout ] ?dups thunk with 214 | | pid, [ `InChannel c ] -> stash pid procref; 215 | c 216 | | _ -> raise Bug 217 | 218 | let open_thunk_out ?procref ?dups thunk = 219 | match open_thunk ~pipes:[ `InDescr Unix.stdin ] ?dups thunk with 220 | | pid, [ `OutChannel c ] -> stash pid procref; 221 | c 222 | | _ -> raise Bug 223 | 224 | let open_thunk2 ?procref ?dups thunk = 225 | match open_thunk ~pipes:[ `OutDescr Unix.stdout; 226 | `OutDescr Unix.stderr ] 227 | ?dups thunk with 228 | | pid, [ `InChannel out; 229 | `InChannel err ] -> stash pid procref; 230 | out, err 231 | | _ -> raise Bug 232 | 233 | let open_thunk3 ?procref ?dups thunk = 234 | match open_thunk ~pipes:[ `InDescr Unix.stdin; 235 | `OutDescr Unix.stdout; 236 | `OutDescr Unix.stderr ] 237 | ?dups thunk with 238 | | pid, [ `OutChannel inc; 239 | `InChannel out; 240 | `InChannel err ] -> stash pid procref; 241 | inc, out, err 242 | | _ -> raise Bug 243 | 244 | let protect_thunk kont thunk = 245 | IVar.with_interprocess_protect @@ fun protect -> 246 | kont (fun _ -> protect thunk) 247 | 248 | let with_command kont command = 249 | protect_thunk kont (fun _ -> Proc.exec command) 250 | 251 | let open_command ?pipes ?dups = 252 | with_command (open_thunk ?pipes ?dups) 253 | 254 | let open_command_in ?procref ?dups = 255 | with_command (open_thunk_in ?procref ?dups) 256 | 257 | let open_command_out ?procref ?dups = 258 | with_command (open_thunk_out ?procref ?dups) 259 | 260 | let open_command2 ?procref ?dups = 261 | with_command (open_thunk2 ?procref ?dups) 262 | 263 | let open_command3 ?procref ?dups = 264 | with_command (open_thunk3 ?procref ?dups) 265 | 266 | let with_program kont ?path prog ?argv0 args = 267 | protect_thunk kont (fun _ -> Proc.exec_program ?path prog ?argv0 args) 268 | 269 | let open_program ?pipes ?dups = 270 | with_program (open_thunk ?pipes ?dups) 271 | 272 | let open_program_in ?procref ?dups = 273 | with_program (open_thunk_in ?procref ?dups) 274 | 275 | let open_program_out ?procref ?dups = 276 | with_program (open_thunk_out ?procref ?dups) 277 | 278 | let open_program2 ?procref ?dups = 279 | with_program (open_thunk2 ?procref ?dups) 280 | 281 | let open_program3 ?procref ?dups = 282 | with_program (open_thunk3 ?procref ?dups) 283 | 284 | let open_string_in str = 285 | open_thunk_in (fun _ -> print_string str) 286 | 287 | let string_of_channel c = 288 | let bufsize = 1024 in 289 | let buf = Buffer.create bufsize in 290 | let str = Bytes.make bufsize '\000' in 291 | let rec loop c = 292 | match Pervasives.input c str 0 bufsize with 293 | | 0 -> Buffer.contents buf 294 | | n -> Buffer.add_subbytes buf str 0 n; 295 | loop c in 296 | loop c 297 | 298 | let string_of_command ?procref cmd = 299 | let c = open_command_in ?procref cmd in 300 | unwind_protect (fun _ -> string_of_channel c) (fun _ -> close_in c) 301 | 302 | let string_of_program ?procref ?path prog ?argv0 args = 303 | let c = open_program_in ?procref ?path prog ?argv0 args in 304 | unwind_protect (fun _ -> string_of_channel c) (fun _ -> close_in c) 305 | 306 | let with_out_string kont = 307 | let subin, subout, suberr = open_thunk3 (fun _ -> 308 | print_string (string_of_channel stdin) 309 | ) in 310 | unwind_protect (fun _ -> 311 | let r = kont subin in 312 | close_out subin; 313 | r, string_of_channel subout 314 | ) (fun _ -> 315 | close_out subin; 316 | close_in subout; 317 | close_in suberr 318 | ) 319 | 320 | module Dup = struct 321 | type dup_arg = dup_source * gen_channel 322 | 323 | let ( !% ) d = fd_of_descr d 324 | 325 | let ( *<& ) a b = ((b, a) :> dup_arg) 326 | let ( *>& ) a b = ((b, a) :> dup_arg) 327 | let ( *< ) a b = a *<& `Filename b 328 | let ( *> ) a b = a *>& `Filename b 329 | let ( *>! ) a b = a *>& `Filespec (b, `Clobber) 330 | let ( *>? ) a b = a *>& `Filespec (b, `NoClobber) 331 | let ( *>> ) a b = a *>& `Filespec (b, `Append) 332 | let ( *>>! ) a b = a *>& `Filespec (b, `AppendOnly) 333 | 334 | let ( %<& ) a b = `InFd a *<& `InFd b 335 | let ( %>& ) a b = `OutFd a *>& `OutFd b 336 | let ( %< ) a b = `InFd a *< b 337 | let ( %> ) a b = `OutFd a *> b 338 | let ( %>! ) a b = `OutFd a *>! b 339 | let ( %>? ) a b = `OutFd a *>? b 340 | let ( %>> ) a b = `OutFd a *>> b 341 | let ( %>>! ) a b = `OutFd a *>>! b 342 | 343 | let ( /<& ) a b = `InChannel a *<& `InChannel b 344 | let ( />& ) a b = `OutChannel a *>& `OutChannel b 345 | let ( /< ) a b = `InChannel a *< b 346 | let ( /> ) a b = `OutChannel a *> b 347 | let ( />! ) a b = `OutChannel a *>! b 348 | let ( />? ) a b = `OutChannel a *>? b 349 | let ( />> ) a b = `OutChannel a *>> b 350 | let ( />>! ) a b = `OutChannel a *>>! b 351 | 352 | let ( *>% ) a b = a *>& `OutFd b 353 | let ( *>/ ) a b = a *>& `OutChannel b 354 | let ( %>* ) a b = `OutFd a *>& b 355 | let ( %>/ ) a b = `OutFd a *>& `OutChannel b 356 | let ( />* ) a b = `OutChannel a *>& b 357 | let ( />% ) a b = `OutChannel a *>& `OutFd b 358 | 359 | let ( *<% ) a b = a *<& `InFd b 360 | let ( *" (fd_of_descr descr) 395 | 396 | let pp_in_channel fmt ic = 397 | Format.fprintf fmt "" 398 | (fd_of_descr (descr_of_gen (`InChannel ic))) 399 | 400 | let pp_out_channel fmt oc = 401 | Format.fprintf fmt "" 402 | (fd_of_descr (descr_of_gen (`OutChannel oc))) 403 | -------------------------------------------------------------------------------- /lib/delimited.ml: -------------------------------------------------------------------------------- 1 | (* Implementation of delimited text formats. *) 2 | 3 | type options = { 4 | field_sep: char; 5 | record_sep: char; 6 | trim_space: bool; 7 | rec_backslash: bool; 8 | rec_quotation: bool; 9 | rec_double_double: bool; 10 | rec_cr: bool; 11 | rec_escapes: bool; 12 | max_fields: int; 13 | } 14 | 15 | let default_options = { 16 | field_sep = ','; 17 | record_sep = '\n'; 18 | trim_space = true; 19 | rec_backslash = false; 20 | rec_quotation = true; 21 | rec_double_double = true; 22 | rec_cr = true; 23 | rec_escapes = false; 24 | max_fields = 0; 25 | } 26 | 27 | (* Here begins the record reader state machine. *) 28 | module R = struct 29 | (* Here we're about to handle any character that's not inside 30 | * quotes. The current character is passed in, because other 31 | * parts of the machine may look ahead at it. *) 32 | let rec start options channel buf c = 33 | match c with 34 | | _ when c = options.record_sep -> 35 | Reader.raw_of_string (Buffer.contents buf) 36 | | '"' when options.rec_quotation -> 37 | Buffer.add_char buf '"'; 38 | quotation options channel buf 39 | | '\\' when options.rec_backslash 40 | || options.rec_escapes -> 41 | backslash options channel buf; 42 | start options channel buf (input_char channel) 43 | | '\r' when options.rec_cr -> 44 | let c = try input_char channel 45 | with End_of_file -> ' ' in 46 | if c = options.record_sep 47 | then Reader.raw_of_string ~after:"\r\n" (Buffer.contents buf) 48 | else failwith "Csv.reader: got CR without LF" 49 | | _ -> 50 | Buffer.add_char buf c; 51 | start options channel buf (input_char channel) 52 | (* Here we're inside double quotes. *) 53 | and quotation options channel buf = 54 | let c = try input_char channel 55 | with End_of_file -> 56 | failwith "Csv.reader: EOF during quotation" in 57 | match c with 58 | | '\\' when options.rec_backslash 59 | || options.rec_escapes -> 60 | backslash options channel buf; 61 | quotation options channel buf 62 | | '"' -> 63 | Buffer.add_char buf '"'; 64 | let c = input_char channel in 65 | if c = '"' 66 | then 67 | begin 68 | Buffer.add_char buf '"'; 69 | quotation options channel buf 70 | end 71 | else start options channel buf c 72 | | _ -> 73 | Buffer.add_char buf c; 74 | quotation options channel buf 75 | (* We just saw a backslash and we're in backslash mode, 76 | * so there better be another character following it. *) 77 | and backslash options channel buf = 78 | try let c = input_char channel in 79 | Buffer.add_char buf '\\'; 80 | Buffer.add_char buf c with 81 | | End_of_file -> 82 | if options.rec_backslash then 83 | failwith "Csv.reader: recognized backslash at EOF" 84 | else 85 | Buffer.add_char buf '\\' 86 | 87 | (* The above code guards against end_of_file only in places that 88 | * require special treatment. The other case is that we catch 89 | * it out here and wrap things up. *) 90 | let reader ?(options = default_options) channel = 91 | let buf = Buffer.create 80 in 92 | try 93 | start options channel buf (input_char channel) 94 | with 95 | End_of_file when Buffer.length buf > 0 -> 96 | Reader.raw_of_string ~after:"" (Buffer.contents buf) 97 | end 98 | 99 | let reader = R.reader 100 | 101 | (* Support code for \xHH and \OOO. *) 102 | let hex_digit = function 103 | | '0' .. '9' as c -> int_of_char c - int_of_char '0' 104 | | 'a' .. 'f' as c -> int_of_char c - int_of_char 'a' + 10 105 | | 'A' .. 'F' as c -> int_of_char c - int_of_char 'A' + 10 106 | | c -> failwith (Printf.sprintf 107 | "Got `%c' where hex digit expected" c) 108 | let oct_digit = function 109 | | '0' .. '7' as c -> int_of_char c - int_of_char '0' 110 | | c -> failwith (Printf.sprintf 111 | "Got `%c' where octal digit expected" c) 112 | 113 | (* 114 | * The field-splitting state machine commences. 115 | *) 116 | let splitter ?(options = default_options) record = 117 | let buf = Buffer.create 80 in 118 | let limit = String.length record in 119 | 120 | (* We just saw a backslash. We may be in rec_backslash mode, 121 | * escapes mode, or both. If we're in rec_backslash 122 | * mode, we require another character to work with, but in 123 | * escapes mode, that's optional because we treat it as a code 124 | * we don't recognize and return the backslash. *) 125 | let backslash i = 126 | if i + 1 >= limit then 127 | if options.rec_backslash then 128 | failwith "Csv.splitter: backslash at end of record" 129 | else '\\', 1 130 | else 131 | match record.[i + 1] with 132 | (* If we're not recognizing backslash codes, we must be 133 | * recognizing backslashes, and we're done. *) 134 | | c when not options.rec_escapes -> 135 | c, 2 136 | (* Translate codes. *) 137 | | '"' -> '"', 2 138 | | '\\' -> '\\', 2 139 | | 'a' -> '\007', 2 140 | | 'b' -> '\008', 2 141 | | 'f' -> '\012', 2 142 | | 'n' -> '\010', 2 143 | | 'r' -> '\013', 2 144 | | 't' -> '\009', 2 145 | | 'v' -> '\011', 2 146 | | 'x' -> if i + 3 >= limit then 147 | failwith "Csv.splitter: unfinished \\xHH code" 148 | else 149 | char_of_int(16 * hex_digit record.[i + 2] + 150 | hex_digit record.[i + 3]), 4 151 | | ('0' .. '7') -> 152 | if i + 3 >= limit then 153 | failwith "Csv.splitter: unfinished \\xHH code" 154 | else 155 | char_of_int(64 * oct_digit record.[i + 1] + 156 | 8 * oct_digit record.[i + 2] + 157 | oct_digit record.[i + 3]), 4 158 | (* If we're in both modes and nothing to translate. . . *) 159 | | c when options.rec_backslash -> 160 | c, 2 161 | (* We're only recognizing codes, and there wasn't one there. *) 162 | | _ -> '\\', 1 in 163 | 164 | (* We're at the start of a field. If we're trimming whitespace, then 165 | * do that thing. *) 166 | let rec start n fields i = 167 | if i >= limit 168 | then continue n fields i i 169 | else match record.[i] with 170 | | ' ' | '\t' | '\r' | '\n' when options.trim_space -> 171 | start n fields (i + 1) 172 | | _ -> 173 | continue n fields i i 174 | 175 | (* Traversing a fields, outside of quotation. If we're trimming 176 | * whitespace, we use [mark] to track the beginning of the must recent 177 | * run of space. That way, we can discard it if we hit the end of 178 | * the field or include it if we hit anything else. *) 179 | and continue n fields i mark = 180 | if i >= limit 181 | then List.rev (Buffer.contents buf :: fields) 182 | else match record.[i] with 183 | | c when c = options.field_sep && n <> 1 -> 184 | let fields = Buffer.contents buf :: fields in 185 | Buffer.clear buf; 186 | start (n - 1) fields (i + 1) 187 | | ' ' | '\t' | '\r' | '\n' when options.trim_space -> 188 | continue n fields (i + 1) mark 189 | | '"' when options.rec_quotation -> 190 | for j = mark to i - 1 do 191 | Buffer.add_char buf record.[j] 192 | done; 193 | quotation n fields (i + 1) 194 | | '\\' when options.rec_escapes 195 | || options.rec_backslash -> 196 | for j = mark to i - 1 do 197 | Buffer.add_char buf record.[j] 198 | done; 199 | let c, next = backslash i in 200 | Buffer.add_char buf c; 201 | continue n fields (i + next) (i + next) 202 | | c -> 203 | for j = mark to i - 1 do 204 | Buffer.add_char buf record.[j] 205 | done; 206 | Buffer.add_char buf c; 207 | continue n fields (i + 1) (i + 1) 208 | 209 | (* We're inside quotation marks. *) 210 | and quotation n fields i = 211 | if i >= limit 212 | then failwith "Csv.splitter: end of record during quotation" 213 | else match record.[i] with 214 | | '"' when i + 1 < limit 215 | && record.[i + 1] = '"' 216 | && options.rec_double_double -> 217 | Buffer.add_char buf '"'; 218 | quotation n fields (i + 2) 219 | | '"' -> 220 | continue n fields (i + 1) (i + 1) 221 | | '\\' when options.rec_escapes 222 | || options.rec_backslash -> 223 | let c, next = backslash i in 224 | Buffer.add_char buf c; 225 | quotation n fields (i + next) 226 | | c -> 227 | Buffer.add_char buf c; 228 | quotation n fields (i + 1) in 229 | Array.of_list (start options.max_fields [] 0) 230 | 231 | (* Here is how we output fields. *) 232 | module OF = struct 233 | (* Determine whether quoting (of some sort) is required. Quoting 234 | * is required iff one of: 235 | * - There's leading or trailing space and we trim space 236 | * - We have a double-quote or CR and we recognize those 237 | * - We have a field delimiter or record separator 238 | *) 239 | let must_quote options field limit = 240 | if limit = 0 then 241 | if options.trim_space && 242 | String.contains " \t\r\n" options.field_sep then 243 | if options.rec_quotation then 244 | true 245 | else 246 | failwith "sheeit" 247 | else 248 | false 249 | else try 250 | match field.[0], field.[limit - 1] with 251 | | (' '|'\t'),_ | _,(' '|'\t') when options.trim_space -> 252 | raise Exit 253 | | _ -> 254 | for i = 0 to limit - 1 do 255 | match field.[i] with 256 | | '"' when options.rec_quotation -> 257 | raise Exit 258 | | '\r' when options.rec_cr -> 259 | raise Exit 260 | | c when c = options.field_sep 261 | || c = options.record_sep -> 262 | raise Exit 263 | | _ -> () 264 | done; 265 | false 266 | with Exit -> true 267 | 268 | (* Here we've decided to use double-quotes as our quotation device. 269 | * This isn't guaranteed to succeed, because if we see quote but aren't 270 | * allowed to use backslash or doublingthen we can't do it. The 271 | * preferred method is always in closest accordence with CSV. *) 272 | let quotation options field channel limit = 273 | output_char channel '"'; 274 | for i = 0 to limit - 1 do 275 | match field.[i] with 276 | | '"' when options.rec_double_double -> 277 | output_string channel "\"\"" 278 | | '"'|'\\' as c when options.rec_backslash 279 | || options.rec_escapes -> 280 | output_char channel '\\'; 281 | output_char channel c; 282 | | '"' -> 283 | failwith "Csv.output_field: can't quote double quote" 284 | | c -> 285 | output_char channel c 286 | done; 287 | output_char channel '"' 288 | 289 | (* If we choose backslash output and trimming, then we keep track of 290 | * runs of whitespace -- we'll then choose whether to output them 291 | * or without backslashes when we hit either the end of the field 292 | * or non-space characters. *) 293 | let flush_backslash field channel mark i limit plus = 294 | if mark = 0 || i = limit then 295 | for j = mark to i - 1 do 296 | output_char channel '\\'; 297 | output_char channel field.[j] 298 | done 299 | else 300 | for j = mark to i - 1 do 301 | output_char channel field.[j] 302 | done; 303 | for j = i to i + plus - 1 do 304 | output_char channel '\\'; 305 | output_char channel field.[j] 306 | done 307 | 308 | let rec backslash options field channel i mark limit = 309 | if i >= limit then 310 | flush_backslash field channel mark i limit 0 311 | else begin 312 | match field.[i] with 313 | | c when c = options.field_sep 314 | || c = options.record_sep -> 315 | flush_backslash field channel mark i limit 1; 316 | backslash options field channel (i + 1) (i + 1) limit 317 | | '"' when options.rec_quotation -> 318 | flush_backslash field channel mark i limit 1; 319 | backslash options field channel (i + 1) (i + 1) limit 320 | | '\\' -> 321 | flush_backslash field channel mark i limit 1; 322 | backslash options field channel (i + 1) (i + 1) limit 323 | | '\r' when options.rec_cr -> 324 | if i + 1 >= limit || field.[i] <> options.record_sep then 325 | failwith "Csv.output_field: got CR without LF" 326 | else begin 327 | flush_backslash field channel mark i limit 2; 328 | backslash options field channel (i + 2) (i + 2) limit 329 | end 330 | | ' ' | '\t' | '\r' | '\n' when options.trim_space -> 331 | backslash options field channel (i + 1) mark limit 332 | | c -> 333 | flush_backslash field channel mark i limit 0; 334 | output_char channel c; 335 | backslash options field channel (i + 1) (i + 1) limit 336 | end 337 | 338 | let escapes options field channel limit = 339 | for i = 0 to limit - 1 do 340 | let str = match field.[i] with 341 | | '\n' -> Some "\\n" 342 | | '\r' -> Some "\\r" 343 | | '\t' -> Some "\\t" 344 | | '"' -> Some "\\\"" 345 | | '\\' -> Some "\\\\" 346 | | '\000'..'\032' | '\128'..'\255' as c -> 347 | Some (Printf.sprintf "\\x%02x" (int_of_char c)) 348 | | c when c = options.record_sep 349 | || c = options.field_sep -> 350 | Some (Printf.sprintf "\\x%02x" (int_of_char c)) 351 | | _ -> None in 352 | match str with 353 | | Some s -> output_string channel s 354 | | _ -> output_char channel field.[i] 355 | done 356 | 357 | let output_field ?(options = default_options) channel field = 358 | let limit = String.length field in 359 | if must_quote options field limit then 360 | if options.rec_quotation then 361 | quotation options field channel limit 362 | else if options.rec_escapes then 363 | escapes options field channel limit 364 | else if options.rec_backslash then 365 | backslash options field channel 0 0 limit 366 | else 367 | failwith "Csv.output_field: options provide insufficient quoting" 368 | else if options.rec_backslash || 369 | options.rec_escapes then 370 | backslash options field channel 0 0 limit 371 | else 372 | output_string channel field 373 | end 374 | 375 | let output_field = OF.output_field 376 | 377 | let output_line ?(options = default_options) channel record = 378 | let limit = Array.length record in 379 | if limit > 0 then begin 380 | output_field ~options channel record.(0); 381 | for i = 1 to limit - 1 do 382 | output_char channel options.field_sep; 383 | output_field ~options channel record.(i) 384 | done; 385 | output_char channel options.record_sep; 386 | flush channel 387 | end 388 | -------------------------------------------------------------------------------- /lib/delimited.mli: -------------------------------------------------------------------------------- 1 | (** Parsers for delimited text formats, especially CSV. This module 2 | * provides a record reader, field splitter, and printer. 3 | * The delimiter, quoting, and whitespace behavior are all 4 | * configurable. *) 5 | 6 | (** Options for parsing delimited text files. *) 7 | type options = { 8 | field_sep: char; 9 | (** The field separator character. (Default [',']) *) 10 | record_sep: char; 11 | (** The record separator character. (Default ['\n']) *) 12 | trim_space: bool; 13 | (** Whether to remove whitespace from the beginning and end of each 14 | * field. (Default [true]) *) 15 | rec_backslash: bool; 16 | (** A backslash quotes the next character. (Default [false]) *) 17 | rec_quotation: bool; 18 | (** Recognize double quotes. (Default [true]) *) 19 | rec_double_double: bool; 20 | (** Within quotation marks, two double quotes in a row 21 | * denote one double quote. (Default [true]) *) 22 | rec_cr: bool; 23 | (** Treat a carriage return that precedes a record 24 | * separator as part of the separator. This, along with setting 25 | * the record separator to ['\n'], will treat MS-DOS CRLF as 26 | * a record separator. *) 27 | rec_escapes: bool; 28 | (** Recognize backslash sequences such as ["\\n"] for newline 29 | * and ["\\t"] for tab. *) 30 | max_fields: int; 31 | (** The maximum number of fields to split into. Field separators 32 | * and fields subsequent to this are all concatenated in the last 33 | * field. A value of [0] (the default) means unlimited. *) 34 | } 35 | 36 | (** The default options. To read records with the default options but 37 | * also recognizing backslash, one might write 38 | * [Csv.reader ~options:{default_options with recognize_backslash = true}]. 39 | *) 40 | val default_options : options 41 | 42 | (** The CSV reader. Splits a file into raw lines, but doesn't interpret 43 | * any quoting; that is, you get out what you put in. *) 44 | val reader : ?options:options -> Reader.t 45 | 46 | (** The CSV splitter. Given a single CSV raw line content, splits it into 47 | * fields and interprets quoting and escaping properly to recover 48 | * the original strings. *) 49 | val splitter : ?options:options -> string -> string array 50 | 51 | (** Output a single field, escaped as necessary for CSV. *) 52 | val output_field : ?options:options -> out_channel -> string -> unit 53 | 54 | (** Output a CSV line, including the newline. *) 55 | val output_line : ?options:options -> out_channel -> string array -> unit 56 | -------------------------------------------------------------------------------- /lib/depDAG.ml: -------------------------------------------------------------------------------- 1 | open Util 2 | 3 | module Q = PriorityQueue 4 | 5 | type task = unit -> Proc.t 6 | 7 | (* We build a process DAG by specifying each process to run 8 | * along with its dependencies. Sharing works. *) 9 | type t = { 10 | goal: task; 11 | prio: int; 12 | deps: t list; 13 | temp: (int ref * (status list) ref) option ref; 14 | } 15 | (* Temporary data for assembly the priority structure. *) 16 | and status = { 17 | s_goal : task; 18 | s_prio : int; 19 | s_next : status list ref; 20 | s_wait : int ref; 21 | } 22 | 23 | let make ?(prio = 0) goal deps = { 24 | goal = goal; 25 | prio = prio; 26 | deps = deps; 27 | temp = ref None; 28 | } 29 | 30 | let make_par ?(prio = 0) deps = { 31 | goal = (fun _ -> Proc.spawn (fun _ -> ())); 32 | prio = prio; 33 | deps = deps; 34 | temp = ref None; 35 | } 36 | 37 | (* We'll manage our state with a priority queue. Function [prepare] 38 | * adds ready-to-go processes to the queue and prepares all processes 39 | * with their reference information. 40 | * 41 | * This code is not reentrant. 42 | *) 43 | let prepare = 44 | (* Helper function to build the priority queue, and allocate the 45 | * refs and connections. *) 46 | let rec build next queue = function 47 | (* Seen nodes *) 48 | | { temp = { contents = Some (my_wait, my_next) } } as n 49 | -> my_next := next @ !my_next; 50 | let me = { s_goal = n.goal; s_prio = n.prio; 51 | s_next = my_next; s_wait = my_wait; } in 52 | List.fold_left (build [me]) queue n.deps 53 | (* Not yet seen nodes *) 54 | | n -> let my_wait = ref (List.length n.deps) in 55 | let my_next = ref [] in 56 | let queue = match n.deps with 57 | | [] -> Q.insert n.prio (n.goal, my_next) queue 58 | | _ -> queue in 59 | n.temp := Some (my_wait, my_next); 60 | build next queue n in 61 | 62 | (* Helper function to clear the cached data from running build. *) 63 | let rec clear n = n.temp := None; List.iter clear n.deps in 64 | 65 | fun dag -> 66 | let it = build [] Q.empty dag in 67 | clear dag; it 68 | 69 | let run = 70 | let add_if_ready queue next = 71 | decr next.s_wait; 72 | if !(next.s_wait) = 0 73 | then Q.insert next.s_prio (next.s_goal, next.s_next) queue 74 | else queue in 75 | 76 | let rec loop n running queue = 77 | match running with 78 | | [] when Q.is_empty queue -> () 79 | | _ when Q.is_empty queue || n = 0 -> 80 | let pid = Proc.wait_any (List.map fst running) in 81 | let queue = List.fold_left add_if_ready queue 82 | (List.assq pid running) in 83 | let running = List.remove_assq pid running in 84 | loop (n + 1) running queue 85 | | _ -> 86 | let (goal, next) = Q.peek queue in 87 | let queue = Q.remove_min queue in 88 | let pid = goal () in 89 | loop (n - 1) ((pid, !next) :: running) queue in 90 | 91 | fun ?(n = 1) dag -> loop n [] (prepare dag) 92 | 93 | (* 94 | let test str = {| 95 | Proc.spawn {| 96 | print_int (Unix.getpid ()); 97 | print_string ": "; 98 | print_endline str; 99 | ignore (input_line stdin) 100 | |} 101 | |} 102 | 103 | let a = make (test "A") [ ] 104 | let b1 = make (test "B1") [ a ] 105 | let b2 = make (test "B2") [ a ] 106 | let c = make (test "C") [ ] 107 | let d = make (test "D") [ b1; b2; c ] 108 | 109 | let dag = d 110 | ;; 111 | run 3 dag 112 | *) 113 | -------------------------------------------------------------------------------- /lib/depDAG.mli: -------------------------------------------------------------------------------- 1 | (** Evaluates dependency DAGs of processes in parallel. *) 2 | 3 | (** A task is specified as a thunk that starts a process. *) 4 | type task = unit -> Proc.t 5 | 6 | (** A DAG of tasks. *) 7 | type t 8 | 9 | (** Make a DAG whose goal is a task, given a list of prereqisite DAGs. 10 | * Takes an optional priority, used to decide which tasks to schedule 11 | * first; lower integers are scheduled first, and default is 0. *) 12 | val make : ?prio:int -> task -> t list -> t 13 | 14 | (** Make a DAG whose goal comprises all the goals in the list. *) 15 | val make_par : ?prio:int -> t list -> t 16 | 17 | (** Run a DAG with the specified parallelism. Default [n] is 0. *) 18 | val run : ?n:int -> t -> unit 19 | -------------------------------------------------------------------------------- /lib/disposal.ml: -------------------------------------------------------------------------------- 1 | open Util 2 | 3 | module type DISPOSABLE = sig 4 | type t 5 | val equal : t -> t -> bool 6 | val hash : t -> int 7 | val default : t -> unit 8 | end 9 | 10 | module type DISPOSAL = sig 11 | type data 12 | val register : (data -> unit) -> data -> data 13 | val manage : ?disposer:(data -> unit) -> data -> data 14 | val dispose : data -> unit 15 | end 16 | 17 | module Make(D : DISPOSABLE) = struct 18 | module Table = WeakPlus.Make(struct 19 | include D 20 | type key = t 21 | type data = key -> unit 22 | end) 23 | 24 | type data = D.t 25 | 26 | let table = Table.create 32 27 | 28 | let dispose obj = 29 | try let disposer = Table.find table obj in 30 | Table.remove table obj; 31 | disposer obj 32 | with Not_found -> D.default obj 33 | 34 | let only_once f = 35 | let todo = ref true in 36 | fun x -> if !todo then (f x; todo := false) 37 | 38 | let raw_register disposer obj kont = 39 | if disposer == D.default then 40 | kont D.default 41 | else 42 | let disposer = only_once disposer in 43 | Table.add table obj disposer; 44 | kont disposer 45 | 46 | let register disposer obj = 47 | raw_register disposer obj ignore; 48 | obj 49 | 50 | let manage ?(disposer=D.default) obj = 51 | raw_register disposer obj (flip Gc.finalise obj); 52 | obj 53 | end 54 | -------------------------------------------------------------------------------- /lib/disposal.mli: -------------------------------------------------------------------------------- 1 | (** 2 | * Registries for semi-automatic object disposal. 3 | * [Disposal.Make(D)] creates a registry for disposal of objects of 4 | * type [D.t]. 5 | * 6 | * {!Disposal} ensures that for any managed object, 7 | * a disposer is called only once, whether manually or automatically, 8 | * {b except} for the default disposer [D.default], 9 | * which must be safe to call multiple times on any already-disposed 10 | * object. 11 | *) 12 | 13 | (** The input signature of the functor {!Disposal.Make}. *) 14 | module type DISPOSABLE = sig 15 | type t 16 | (** The type to dispose *) 17 | val equal : t -> t -> bool 18 | (** Identity predicate to associate objects with disposal actions. *) 19 | val hash : t -> int 20 | (** Hash function for managed objects. *) 21 | val default : t -> unit 22 | (** The default disposal action. Must be safe to call multiple 23 | times on the same object. *) 24 | end 25 | 26 | (** The output signature of the functor {!Disposal.Make}. *) 27 | module type DISPOSAL = sig 28 | (** The type of data being managed. *) 29 | type data 30 | 31 | (** Register a disposal function for a particular object. 32 | Returns the object. *) 33 | val register : (data -> unit) -> data -> data 34 | 35 | (** Request that the garbage collector manage an object. If no 36 | disposal action is given, uses [D.default]. When the object 37 | is collected, the disposal action will be run if the user hasn't 38 | called it manually first (or possibly again, if it's the default 39 | disposer). *) 40 | val manage : ?disposer:(data -> unit) -> data -> data 41 | 42 | (** Manually dispose an object now. If the object is not registered, 43 | uses D.default. *) 44 | val dispose : data -> unit 45 | end 46 | 47 | (** Build a new disposal registry. The {!DISPOSABLE} parameter [D] 48 | specifies how to dispose objects of type [D.t]. *) 49 | module Make(D : DISPOSABLE) : DISPOSAL with type data = D.t 50 | -------------------------------------------------------------------------------- /lib/fitting.mli: -------------------------------------------------------------------------------- 1 | (* vim: set ft=ocaml : *) 2 | (** 3 | * Fittings represent processes, internal or external, that produce, 4 | * consume, or transform data. This module provides basic 5 | * constructors to make fittings out of both external UNIX commands 6 | * and internal {!Shtream} functions, and fitting combinators 7 | * that combine fittings in a variety of ways. 8 | * 9 | * This module includes both functions specialized to shtreams of 10 | * {!Line.t} and a functor for creating a structure specialized for 11 | * sthreams of other types. 12 | *) 13 | 14 | (** {1 Line Fitting Interface} *) 15 | 16 | include FittingSig.S 17 | with type 'a elem = 'a LineShtream.elem 18 | and type initial = LineShtream.initial 19 | and type 'a shtream = 'a LineShtream.t 20 | and type 'a coshtream = 'a LineShtream.co_t 21 | 22 | (** {1 Functorial Interface} *) 23 | 24 | (** Build a new fittings module. The {!Shtream} parameter specifies the 25 | underlying shtream implementation to use. *) 26 | module Make(Shtream : AnyShtream.S) : FittingSig.S 27 | with type initial = Shtream.initial 28 | and type 'a elem = 'a Shtream.elem 29 | and type 'a shtream = 'a Shtream.t 30 | and type 'a coshtream = 'a Shtream.co_t 31 | -------------------------------------------------------------------------------- /lib/fittingSig.ml: -------------------------------------------------------------------------------- 1 | (* vim: set ft=ocaml : *) 2 | (** Generic signature for Fittings. *) 3 | 4 | open Channel 5 | open Channel.Dup 6 | 7 | module type S = sig 8 | 9 | (** {1 Types} *) 10 | 11 | (** A fitting that consumes values of type ['a] and produces 12 | * values of type ['b]. 13 | *) 14 | type 'a t 15 | constraint 'a = 'b -> 'c 16 | 17 | (** This is the type of elements that fittings know how to write to external 18 | processes. *) 19 | type 'a elem 20 | 21 | (** This is the parameter to the type {!elem} for specifying 22 | * the type of elements that fittings know how to read from 23 | * external processes. That is, fittings constructed from external 24 | * processes produce values of type [initial elem]. *) 25 | type initial 26 | 27 | type 'a shtream 28 | type 'a coshtream 29 | 30 | (** Alias for {!Channel.procref} *) 31 | type procref = Channel.procref 32 | 33 | (** Alias for {!initial} {!elem} *) 34 | type text = initial elem 35 | 36 | (** {1 Values} *) 37 | 38 | (** Connect the output of one fitting to the input of another. 39 | * This is the most basic fitting combinator, and bears introduction 40 | * before the full variety of fitting components. *) 41 | val ( -| ) : ('a -> 'b) t -> ('b -> 'c) t -> ('a -> 'c) t 42 | 43 | val pipe : ('i -> 'm) t -> ('m -> 'o) t -> ('i -> 'o) t 44 | (** Alias for {!(-|)} *) 45 | 46 | (** {2 Basic Fitting Constructors} 47 | * 48 | * {3 Producers} 49 | * 50 | * Producers are useful for starting off pipelines. 51 | *) 52 | 53 | val from_file : string -> ('i -> text) t 54 | (** Produce the contents of a file. 55 | * [from_file file -| fitting] is like {v % fitting < file v} *) 56 | val from_null : ('i -> text) t 57 | (** Produce nothing. 58 | * [from_null -| fitting] is like {v % fitting < /dev/null v} *) 59 | val from_gen : Channel.dup_in_source -> ('i -> text) t 60 | (** Produce the contents of a {!Channel.dup_in_source}. *) 61 | val from_shtream: 'o shtream -> ('i -> 'o) t 62 | (** Produce the contents of a shtream. *) 63 | 64 | (** {3 Consumers} 65 | * 66 | * Consumers are useful for ending pipelines. 67 | * *) 68 | 69 | val to_file : ?clobber:Channel.clobber_spec -> 70 | string -> ('i elem -> 'o) t 71 | (** Redirect standard output to a file. 72 | * See {!Channel.clobber_spec} for open modes. 73 | * [fitting -| to_file file] is like {v % fitting > file v} *) 74 | val to_null : ('i elem -> 'o) t 75 | (** Redirect standard output nowhere. 76 | * [fitting -| to_null] is like {v % fitting > /dev/null v} *) 77 | val to_stderr : ('i elem -> 'o) t 78 | (** Redirect standard output to standard error. 79 | [fitting -| to_stderr] is like {v % fitting >&2 v} *) 80 | val to_gen : Channel.dup_out_source -> ('i elem -> 'o) t 81 | (** Redirect standard output to {!Channel.dup_out_source}. *) 82 | val to_coshtream: 'i coshtream -> ('i -> 'o) t 83 | (** Redirect output to a coshtream. (A coshtream is a consumer 84 | * in another process.) *) 85 | 86 | (** {3 Transformers} *) 87 | 88 | (** Run an external command as a fitting. The fitting's input is 89 | * connected to the command's standard input and the fitting's output 90 | * to the command's standard output. This runs the command in the 91 | * shell, in the style of {!Channel.open_command}. *) 92 | val command : string -> ('i elem -> text) t 93 | 94 | (** Run an external program as a fitting. The fitting's input is 95 | * connected to the program's standard input and the fitting's output 96 | * to the program's standard output. This runs the program in the 97 | * shell, in the style of {!Channel.open_program}. *) 98 | val program : ?path:bool -> string -> ?argv0:string -> string list -> 99 | ('i elem -> text) t 100 | 101 | (** Run a thunk as a fitting. The thunk is run in a child 102 | * process whose standard input and output are connected to the 103 | * fitting's input and output. *) 104 | val thunk : (unit -> unit) -> ('i elem -> text) t 105 | 106 | (** Map each element according to a function. 107 | * This lifts a function on elements into a fitting component. *) 108 | val sed : ('i -> 'o) -> ('i -> 'o) t 109 | 110 | (** Filter the input according to a predicate. *) 111 | val grep : ('i -> bool) -> ('i -> 'i) t 112 | 113 | (** Transform the input according to a function on shtreams. *) 114 | val trans : ('i shtream -> 'o shtream) -> ('i -> 'o) t 115 | 116 | (** Like {!sed} with a lift from strings. *) 117 | val sed_string : (string -> 'o) -> ('i elem -> 'o) t 118 | 119 | (** Filter the input according to a string predicate. *) 120 | val grep_string : (string -> bool) -> ('i elem -> 'i elem) t 121 | 122 | (** {2 Fitting Combinators} *) 123 | 124 | val ( / 'o) t -> dup_spec -> (text -> 'o) t 125 | (** Redirect some inputs to a fitting. [fitting / (text -> 'o) t -> (text -> 'o) t 133 | (** Alias for {!(// ) : ('i -> 'o elem) t -> dup_spec -> ('i -> 'o elem) t 136 | (** Redirect some outputs from a fitting. [fitting />/ dups] 137 | * performs the redirections specifed by [dups] for the extent 138 | * of [fitting]. For example, 139 | * [fitting />/ \[ 2 %>& 1 \]] is like 140 | * {v % fitting 2>&1 v} 141 | *) 142 | val redirect_out : dup_spec -> ('i -> 'o elem) t -> ('i -> 'o elem) t 143 | (** Alias for {!(/>/)} *) 144 | 145 | val (^>>=) : ('i -> 'o) t -> 146 | (Proc.status -> ('i -> 'o) t) -> 147 | ('i -> 'o) t 148 | (** Sequence two fittings, with control. 149 | * Runs its first argument, passes 150 | * it's exit code to the second argument, and runs the resulting 151 | * fitting. The second argument can therefore choose what to do 152 | * based on the result of the first. 153 | * 154 | * The exit code of external processes is the actual exit code as 155 | * reported by {!Proc.wait}. The exit code of a shtream is 0 unless 156 | * the shtream terminates by calling [Shtream.fail_with n], in which 157 | * case the code in [n]. Or, {!yield} can return an exit code 158 | * directly. 159 | *) 160 | 161 | val seq : ('i -> 'o) t -> 162 | (Proc.status -> ('i -> 'o) t) -> 163 | ('i -> 'o) t 164 | (** Alias for {!(^>>=)} *) 165 | 166 | val (^>>) : ('i -> 'o) t -> ('i -> 'o) t -> ('i -> 'o) t 167 | (** Sequence two fittings, ignoring the exit code of the first. 168 | * [ a ^>> b ] is exactly [ a ^>>= fun _ -> b ]. 169 | * This is like [;] in the shell. *) 170 | val (&&^) : ('i -> 'o) t -> ('i -> 'o) t -> ('i -> 'o) t 171 | (** Sequence two fittings, running the second if the first succeeds. 172 | * If the first fails, skips the second and propagates the exit 173 | * code from the first. 174 | * This is like [&&] in the shell. *) 175 | val (||^) : ('i -> 'o) t -> ('i -> 'o) t -> ('i -> 'o) t 176 | (** Sequence two fittings, running the second if the first fails. 177 | * If the first succeeds, skips the second and returns an exit code 178 | * of 0. 179 | * This is like [||] in the shell. *) 180 | 181 | val (~>>) : ('i -> 'o) t list -> ('i -> 'o) t 182 | (** Run a list of fittings in sequence with {!(^>>)}. *) 183 | val (~&&) : ('i -> 'o) t list -> ('i -> 'o) t 184 | (** Run a list of fittings in sequence with {!(&&^)}. 185 | * Terminates the sequence when any component fails. *) 186 | val (~||) : ('i -> 'o) t list -> ('i -> 'o) t 187 | (** Run a list of fittings in sequence with {!(||^)}. 188 | * Terminates the sequence when any component succeeds. *) 189 | val commands : string list -> (text -> text) t 190 | (** Run a list of commands, piping the output of each 191 | * into the next. *) 192 | 193 | val yield : Proc.status -> ('i -> 'o) t 194 | (** Produces a fitting that returns the given exit code. 195 | * Has no effect on input and output, but can be used to pass a 196 | * particular code along in a sequence. 197 | *) 198 | 199 | val caml : (unit -> ('i -> 'o) t) -> ('i -> 'o) t 200 | (** Delay an OCaml thunk until a fitting is run. Given a thunk 201 | * that produces a fitting, {!caml} constructs a new fitting that, 202 | * when run, forces the thunk and runs the resulting fitting. 203 | * This allows for OCaml side-effects at arbitrary points during a 204 | * fitting. 205 | *) 206 | 207 | val (^&=) : (text -> 'b elem) t -> (Proc.t -> ('i -> 'o) t) -> ('i -> 'o) t 208 | (** Run a fitting in the background. [ bg ^&= fg ] runs [bg] 209 | * in the background, passed its {!Proc.t} to [fg], and runs 210 | * the fitting returned by [fg] (in the foreground). 211 | * 212 | * Notice that the [bg] must have input type {!text}; it will 213 | * construct its own input shtream from the standard input. *) 214 | val par : (text -> 'b elem) t -> (Proc.t -> ('i -> 'o) t) -> ('i -> 'o) t 215 | (** Alias for {!(^&=)} *) 216 | 217 | val (^&) : (text -> 'b elem) t -> ('i -> 'o) t -> ('i -> 'o) t 218 | (** Run a fitting in the background, ignore its {!Proc.t}. This 219 | * backgrounds its first argument and then continues with its second 220 | * argument in the foreground. *) 221 | 222 | (** {2 Fitting Runners} *) 223 | 224 | 225 | val run_source : (text -> 'o) t -> 'o shtream 226 | (** Run a fitting, returning its output as a shtream. The fitting 227 | * will take its input from the standard input. *) 228 | val run_sink : ('i -> 'o elem) t -> 'i coshtream 229 | (** Run a fitting, returning a costhream connected to its input. 230 | * The fitting will send its output from the standard output. *) 231 | val run_list : (text -> 'o) t -> 'o list 232 | (** Run a fitting, returning its output as a list. The fitting 233 | * will take its input from the standard input. *) 234 | 235 | val run_shtream : ('i -> 'o) t -> 'i shtream -> 'o shtream 236 | (** 237 | * Transform a fitting into a shtream transformer. 238 | *) 239 | 240 | val run_in : ?procref:procref -> (text -> 'o elem) t -> in_channel 241 | (** Run a fitting, returning its output as an [in_channel]. The fitting 242 | * will take its input from the standard input. If [?procref] is 243 | * provided, the {!Proc.t} of the child process will be stashed. 244 | *) 245 | val run_out : ?procref:procref -> (text -> 'o elem) t -> out_channel 246 | (** Run a fitting, returning its input as an [out_channel]. The fitting 247 | * will send its output from the standard output. If [?procref] is 248 | * provided, the {!Proc.t} of the child process will be stashed. 249 | *) 250 | 251 | val run_backquote : ?procref:procref -> (text -> 'o elem) t -> string 252 | (** Run a fitting, returning its output collected as a string. 253 | * The exit code of the child process can be retrieved by providing 254 | * [?procref]. *) 255 | 256 | val run_bg : (text -> 'o elem) t -> Proc.t 257 | (** Run a fitting in the background, returning its {!Proc.t}. 258 | * The fitting will take its input from the standard input and send 259 | * its output to the standard output. *) 260 | val run : (text -> 'o elem) t -> Proc.status 261 | (** Run a fitting in the foreground, returning its exit status. 262 | * The fitting will take its input from the standard input and send 263 | * its output to the standard output. *) 264 | 265 | (** {2 Convenient Conversions} 266 | 267 | * These conversions use the {!elem} conversions provided to the 268 | * {!Fitting.Make} functor by {!AnyShtream.ELEM}. The conversion 269 | * {!AnyShtream.ELEM.string_of} or {!AnyShtream.ELEM.of_string} 270 | * is completely applied for each of these conversions, so no state 271 | * (should there be any) is retained in between calls. 272 | *) 273 | 274 | val string_of_elem : 'a elem -> string 275 | (** Convert a shtream element to a string. *) 276 | val elem_of_string : string -> text 277 | (** Convert a string to a shtream element. *) 278 | val int_of_elem : 'a elem -> int 279 | (** Convert a shtream element to an integer. *) 280 | val elem_of_int : int -> text 281 | (** Convert a integer to a shtream element. *) 282 | val char_of_elem : 'a elem -> char 283 | (** Convert a shtream element to a character. *) 284 | val elem_of_char : char -> text 285 | (** Convert a character to a shtream element. *) 286 | val float_of_elem : 'a elem -> float 287 | (** Convert a shtream element to a float. *) 288 | val elem_of_float : float -> text 289 | (** Convert a float to a shtream element. *) 290 | val bool_of_elem : 'a elem -> bool 291 | (** Convert a shtream element to a boolean. *) 292 | val elem_of_bool : bool -> text 293 | (** Convert a boolean to a shtream element. *) 294 | end 295 | -------------------------------------------------------------------------------- /lib/flags.mli: -------------------------------------------------------------------------------- 1 | (** Quick and dirty argument processing. For full featured argument 2 | * processing, use [Arg], but if all you need is something very simple, 3 | * {!Flags} might do. *) 4 | 5 | (** Raised by methods {!lookup.string} and {!lookup.int} 6 | * when the requested argument isn't present. *) 7 | exception Argument_missing of string 8 | 9 | (** The argument parser {!Flags.go} returns an object for querying 10 | * its results. *) 11 | class type lookup = object 12 | 13 | (** Look up the value of a [bool] flag. *) 14 | method bool : string -> bool 15 | 16 | (** Look up the value of an [int] flag; if multiple values were given, 17 | * returns the last one. If the flag wasn't given but [?default] is 18 | * provided, returns that; otherwise throws {!Flags.Argument_missing}. *) 19 | method int : ?default:int -> string -> int 20 | 21 | (** Look up the value of a [string] flag; if multiple values were given, 22 | * returns the last one. If the flag wasn't given but [?default] is 23 | * provided, returns that; otherwise throws {!Flags.Argument_missing}. *) 24 | method string : ?default:string -> string -> string 25 | 26 | (** Look up how many times a particular [bool] flag was given. *) 27 | method bcount : string -> int 28 | 29 | (** Return all the values given with an [int] flag. *) 30 | method ints : string -> int list 31 | 32 | (** Return all the values given with a [string] flag. Passing the 33 | * empty string [""] will return all additional (non-flag) arguments. *) 34 | method strings : string -> string list 35 | 36 | (** Print usage information on [stdout] *) 37 | method usage : unit 38 | 39 | end 40 | 41 | (** [Flags.go spec] parses the command-line arguments according to 42 | * [spec] and returns a [lookup] object. If [?argv] is given, it uses 43 | * that rather than [Sys.argv]; if [?usage] is given, it uses that as 44 | * the sample command in the usage message. 45 | * 46 | * The [spec] argument is a stylized sequence of arguments: 47 | * - ["-a"] and ["--apple"] specify boolean flags. 48 | * - ["-a "] and ["--apple "] specify string arguments. 49 | * - ["-a "] and ["--apple "] specify integer arguments. 50 | * 51 | * Single-hyphen arguments consist of one alphabetic character, while 52 | * long (double-hyphen) arguments start with an alphabetic character 53 | * followed by an arbitrary number of alphanumerics. 54 | * 55 | * For example, we might use 56 | * ["-q -v -b -a --baz "] to specify 57 | * a program that takes boolean flags ["-q"] and ["-v"], integer 58 | * arguments ["-b"] and ["-a"], and a string argument ["--baz"]. If we 59 | * pass this string to {!Flags.go} and it returns an object 60 | * [lookup], we may then query lookup, for example: 61 | * - [lookup#bool "-q"] checks whether ["-q"] was given. 62 | * - [lookup#int "-b"] returns an integer if ["-b"] was given, or raises 63 | * {!Flags.Argument_missing} otherwise. 64 | * - [lookup#ints "-a"] returns a list of integers (possibly 0 length) for 65 | * each time ["-a"] was given. 66 | * - [lookup#string ~default:"-" "--baz"] returns the provided string if 67 | * ["--baz"] was given, and ["-"] otherwise. 68 | *) 69 | val go : ?argv:string array -> 70 | ?usage:string -> 71 | string -> lookup 72 | -------------------------------------------------------------------------------- /lib/flags.mll: -------------------------------------------------------------------------------- 1 | { 2 | exception Argument_missing of string 3 | 4 | let arg_missing s = raise (Argument_missing s) 5 | 6 | type opt = 7 | | Bool of int ref 8 | | String of string list ref 9 | | Int of int list ref 10 | 11 | class lookup find args usage = object 12 | method bool k = match find k with 13 | | Bool r -> !r > 0 14 | | _ -> arg_missing k 15 | 16 | method int ?default k = match find k with 17 | | Int { contents = v :: _ } -> v 18 | | _ -> match default with 19 | | Some v -> v 20 | | _ -> arg_missing k 21 | 22 | method string ?default k = match find k with 23 | | String { contents = v :: _ } -> v 24 | | _ -> match default with 25 | | Some v -> v 26 | | _ -> arg_missing k 27 | 28 | method bcount k = match find k with 29 | | Bool r -> !r 30 | | _ -> 0 31 | 32 | method ints k = match find k with 33 | | Int r -> List.rev !r 34 | | _ -> [] 35 | 36 | method strings k = match find k with 37 | | String r -> List.rev !r 38 | | _ -> [] 39 | 40 | method usage = Arg.usage args usage; 41 | flush stdout 42 | end 43 | 44 | module SM = Map.Make(String) 45 | 46 | let argmap = ref SM.empty 47 | let add k v = argmap := SM.add k v !argmap 48 | let clear () = 49 | let anon = ref [] in 50 | argmap := SM.empty; 51 | add "" (String anon); 52 | fun s -> anon := s :: !anon 53 | 54 | let find () = 55 | let saved = !argmap in 56 | fun k -> SM.find k saved 57 | } 58 | 59 | let alpha = ['a'-'z' 'A'-'Z'] 60 | let digit = ['0'-'9'] 61 | let id = alpha (alpha | digit | '-')* 62 | let ws = (' ' | '\t')+ 63 | 64 | let flag = ('-' alpha | "--" id) 65 | 66 | rule opts = parse 67 | | flag as opt 68 | { 69 | let r = ref 0 in 70 | let set () = r := !r + 1 in 71 | add opt (Bool r); 72 | Some (opt, Arg.Unit set, " Boolean") 73 | } 74 | 75 | | (flag as opt) ('='|ws) '<' (id as name) '>' 76 | { 77 | let r = ref [] in 78 | let set s = r := s :: !r in 79 | add opt (String r); 80 | Some (opt, Arg.String set, " "^name) 81 | } 82 | 83 | | (flag as opt) ('='|ws) '<' (id as name) ":int>" 84 | { 85 | let r = ref [] in 86 | let set i = r := i :: !r in 87 | add opt (Int r); 88 | Some (opt, Arg.Int set, " "^name) 89 | } 90 | 91 | | ws { opts lexbuf } (* eat whitespace *) 92 | | eof { None } 93 | | _ { raise (Invalid_argument "Flags.go") } 94 | 95 | { 96 | let start = !Arg.current 97 | 98 | let rec parse lexbuf = 99 | match opts lexbuf with 100 | | Some o -> o :: parse lexbuf 101 | | None -> [] 102 | 103 | let to_opts str = parse (Lexing.from_string str) 104 | 105 | let go ?argv ?usage str = 106 | let anon = clear () in 107 | let rest = ["--", Arg.Rest anon, " End option processing"] in 108 | let args = Arg.align(to_opts str @ rest) in 109 | let usage = Printf.sprintf "Usage: %s %s" Sys.argv.(0) 110 | (match usage with Some s -> s | _ -> str) in 111 | let argv, current = match argv with 112 | | Some a -> a, ref 0 113 | | None -> Sys.argv, ref start in 114 | try 115 | Arg.parse_argv ~current:(ref 0) argv args anon usage; 116 | new lookup (find ()) args usage 117 | with 118 | | Arg.Bad s -> prerr_string s; exit 2 119 | | Arg.Help h -> print_string h; exit 0 120 | } 121 | -------------------------------------------------------------------------------- /lib/iVar.ml: -------------------------------------------------------------------------------- 1 | open Util 2 | 3 | exception Dead 4 | 5 | type rep = { 6 | read_end : Unix.file_descr; 7 | write_end : Unix.file_descr; 8 | mutable dead : bool; 9 | } 10 | 11 | type 'a read_end = rep 12 | type 'a write_end = rep 13 | 14 | let create () = 15 | let r, w = Unix.pipe () in 16 | Unix.set_close_on_exec r; 17 | Unix.set_close_on_exec w; 18 | let rep = { 19 | read_end = r; 20 | write_end = w; 21 | dead = false; 22 | } in 23 | rep, rep 24 | 25 | (* This isn't thread safe, but threads shouldn't communicate with one-shot 26 | * IVars anyway. *) 27 | let kill rep = 28 | if rep.dead 29 | then raise Dead 30 | else rep.dead <- true 31 | 32 | let write rep v = 33 | kill rep; 34 | Unix.close rep.read_end; 35 | let buf = Marshal.to_bytes v [Marshal.Closures] in 36 | ignore @@ Unix.write rep.write_end buf 0 (Bytes.length buf); 37 | Unix.close rep.write_end 38 | 39 | let read rep = 40 | kill rep; 41 | Unix.close rep.write_end; 42 | let c = Unix.in_channel_of_descr rep.read_end in 43 | let v = try Some (Marshal.from_channel c) 44 | with End_of_file -> None in 45 | Pervasives.close_in c; 46 | v 47 | 48 | let close rep = 49 | kill rep; 50 | Unix.close rep.write_end; 51 | Unix.close rep.read_end 52 | 53 | let with_interprocess_raise_and_okay kont = 54 | let r, w = create () in 55 | let result = kont (fun e -> write w e) (fun () -> close w) in 56 | match read r with 57 | | None -> result 58 | | Some e -> raise e 59 | 60 | let with_interprocess_protect here = 61 | with_interprocess_raise_and_okay 62 | (fun throw ok -> 63 | here (fun there -> 64 | try let r = there () in 65 | ok (); r 66 | with e -> throw e; exit 2)) 67 | 68 | -------------------------------------------------------------------------------- /lib/iVar.mli: -------------------------------------------------------------------------------- 1 | (** One-shot interprocess exceptions and variables. *) 2 | 3 | (** 4 | * {1 Interprocess Exceptions} 5 | *) 6 | 7 | (** Relay exceptions from a subprocess. 8 | [with_interprocess_protect kont] calls [kont] with one 9 | argument, [protect: (unit -> 'a) -> 'a]. 10 | 11 | The function [kont] {b must} fork into an {i observer} process and an 12 | {i observed} process. The observed process {b must not} return from the 13 | call to [kont]; it must, however, call [protect thunk] exactly 14 | once with some thunk, which [protect] will call. When [kont] 15 | returns in the observer process, it blocks until the thunk 16 | returns. If the thunk returns normally (or execs, or exits), then 17 | [protect thunk] returns the result of the thunk in the observed 18 | process, and [with_interprocess_protect] returns the result of 19 | [kont] in the observer process. However, if the thunk raises an 20 | exception, then the observed process terminates with status 2 and 21 | the call to [with_interprocess_protect] in the {i observer} 22 | returns abnormally by re-raising the exception. 23 | 24 | In this example, if {!Proc.exec} raises an exception in the child process, 25 | then [with_interprocess_protect] will re-raise that exception in 26 | the parent process: 27 | 28 | {[ 29 | with_interprocess_protect 30 | (fun protect -> 31 | match Proc.fork () with 32 | | None -> 33 | protect (fun () -> Proc.exec prog args); 34 | exit 3 (* can't happen *) 35 | | Some proc -> proc) 36 | ]} 37 | *) 38 | val with_interprocess_protect 39 | : (((unit -> 'a) -> 'a) -> 'b) -> 'b 40 | 41 | (** Relay exceptions from another process. 42 | [with_interprocess_raise_and_okay kont] calls [kont] with two 43 | arguments, [{ 44 | oops : exn -> unit 45 | okay : unit -> unit 46 | }] 47 | 48 | The function [kont] {b must} fork into an {i observed} process and an 49 | {i observer} process. When the call to [kont] returns in 50 | the {i observer} process, [with_interprocess_raise_and_okay] then 51 | waits for either [oops] or [okay] to be called in the {i observed} 52 | process. If [okay ()] is called, then it returns the result of 53 | [kont]; if [oops e] is called, then it instead raises the exception 54 | [e] in the {i observer} process. If the observed process fails to call 55 | either [oops] or [okay], then the observer process will block 56 | indefinitely. *) 57 | val with_interprocess_raise_and_okay 58 | : ((exn -> unit) -> (unit -> unit) -> 'b) -> 'b 59 | 60 | (** 61 | * {1 Interprocess Variables} 62 | *) 63 | 64 | type 'a read_end 65 | (** The read-end of an interprocess variable. *) 66 | type 'a write_end 67 | (** The write-end of an interprocess variable. *) 68 | 69 | (** Raised on attempts to re-use an {!IVar}. 70 | IVars allow (require, in fact) exactly one read and one write. 71 | *) 72 | exception Dead 73 | 74 | (** Create a channel pair [(r, w)]. The protocol is then as 75 | follows. One process must execute: 76 | - [read r] 77 | 78 | This operation will block, until another process does one of: 79 | - [write w v] : read returns [Some v] 80 | - [close w] : read returns [None] 81 | - [exec ...] : read returns [None] 82 | - [exit ...] : read returns [None ] 83 | 84 | The {!write} call may or may not block, depending on the underlying 85 | implementation. In any case, it is {b imperative} that read 86 | happens in a separate process from the write/close/exec/exit, or 87 | the program may block indefinitely. *) 88 | val create : unit -> 'a read_end * 'a write_end 89 | 90 | (** Read an ['a option] from an {!IVar}. 91 | Blocks until the associated {!write_end} is written or closed. 92 | If [x] is written on the other end, returns [Some x]; if 93 | the other end is closed (including by exit or exec), returns 94 | [None]. 95 | *) 96 | val read : 'a read_end -> 'a option 97 | 98 | (** Write to an {!IVar}. *) 99 | val write : 'a write_end -> 'a -> unit 100 | 101 | (** Close an {!IVar} without writing. *) 102 | val close : 'a write_end -> unit 103 | -------------------------------------------------------------------------------- /lib/lineShtream.ml: -------------------------------------------------------------------------------- 1 | open Util 2 | 3 | type sourced = Line.t 4 | 5 | let annotate source = 6 | let counter = ref 0 in 7 | let each line = 8 | let seq = !counter in 9 | counter := seq + 1; 10 | Line.set_seq seq @@ Line.set_source source line in 11 | Shtream.map each 12 | 13 | let parse_raw_lines source = 14 | let counter = ref 0 in 15 | fun raw -> 16 | let seq = !counter in 17 | counter := seq + 1; 18 | Line.set_seq seq @@ 19 | Line.set_source source @@ 20 | Line.line ~before:raw.Reader.before 21 | ~after:raw.Reader.after 22 | raw.Reader.content 23 | 24 | let line_reader ?(source = `None) reader = 25 | parse_raw_lines source % reader 26 | 27 | module LineElem = struct 28 | type 'a elem = Line.t 29 | type initial = sourced 30 | let reader () = line_reader Reader.lines 31 | let string_of () = Line.show 32 | let of_string () = line_reader Reader.raw_of_string 33 | end 34 | 35 | include AnyShtream.Make(LineElem) 36 | 37 | let elem_reader reader = line_reader reader 38 | 39 | let output ?channel 40 | ?(init = Line.before) 41 | ?(term = Line.after) 42 | ?(show = Line.show) = 43 | output ?channel ~init ~term ~show 44 | 45 | let channel_of ?procref ?before ?after 46 | ?(init = Line.before) 47 | ?(term = Line.after) 48 | ?(show = Line.show) = 49 | channel_of ?procref ?before ?after ~init ~term ~show 50 | 51 | (* Helper for defaulting the reader and making the resulting shtream 52 | * hintable. *) 53 | let default_reader reader source 54 | (kont : ?hint:(Reader.raw_line -> 'b) -> 'a) = 55 | match reader with 56 | | None -> let hint = parse_raw_lines source in 57 | kont ~hint (line_reader ~source Reader.lines) 58 | | Some r -> kont r 59 | 60 | let of_channel ?reader channel = 61 | default_reader reader (`Other "channel") 62 | Shtream.of_channel channel 63 | 64 | let of_file ?reader file = 65 | default_reader reader (`File file) 66 | Shtream.of_file file 67 | 68 | let of_command ?procref ?dups ?reader cmd = 69 | default_reader reader (`Command cmd) 70 | (Shtream.of_command ?procref ?dups) cmd 71 | 72 | let of_program ?procref ?dups ?reader ?path prog ?argv0 args = 73 | default_reader reader (`Process (Proc.execspec ?path prog ?argv0 args)) 74 | (Shtream.of_program ?procref ?dups) 75 | ?path prog ?argv0 args 76 | 77 | let source_parse ?parse source = 78 | maybe parse (fun () -> line_reader ~source Reader.raw_of_string) id 79 | 80 | let of_string_list ?parse lst = 81 | let parse = source_parse ?parse (`Other "list") in 82 | of_string_list ~parse lst 83 | 84 | let of_string_stream ?parse lst = 85 | let parse = source_parse ?parse (`Other "stream") in 86 | of_string_stream ~parse lst 87 | -------------------------------------------------------------------------------- /lib/lineShtream.mli: -------------------------------------------------------------------------------- 1 | (** Shtreams of {!Line.t}s. 2 | * This module is the result of applying {!AnyShtream.Make} to the 3 | * module {!LineElem}. 4 | * Thus, shtreams handled by this module are compatible with the shtreams 5 | * of {!Shtream}, {!StringShtream}, and modules created by 6 | * {!AnyShtream.Make}, but this module provides additional functions 7 | * for reading and writing [Line.t Shtream.t]s. 8 | * 9 | * This module specializes shtream-creating functions to store source 10 | * information in the resulting lines. 11 | *) 12 | 13 | (** A line with source and sequence information. This is the 14 | * {!AnyShtream.ELEM.initial} type for {!LineShtream}. *) 15 | type sourced = Line.t 16 | 17 | (** The parameter given to {!AnyShtream.Make} to build {!LineShtream}. *) 18 | module LineElem : AnyShtream.ELEM 19 | with type 'a elem = Line.t 20 | and type initial = sourced 21 | 22 | (** Most of the types and values in {!LineShtream} come from the 23 | * result of apply {!AnyShtream.Make}. *) 24 | include AnyShtream.S with module Elem = LineElem 25 | 26 | (** Construct a {!Line.t} reader from a record reader. This is like 27 | * {!AnyShtream.S.elem_reader}, but allows specifying a 28 | * {!Line.source} to store in the lines. *) 29 | val line_reader : ?source:Line.source -> Reader.t -> 30 | (in_channel -> initial elem) 31 | 32 | (** Annotate a shtream of lines with source and sequence information. 33 | * If the lines already have [seq] or [source] fields, these are 34 | * rewritten to reflect the given {!Line.source} and current sequence. 35 | *) 36 | val annotate : Line.source -> Line.t t -> Line.t t 37 | -------------------------------------------------------------------------------- /lib/priorityQueue.ml: -------------------------------------------------------------------------------- 1 | open Util 2 | 3 | type 'a t = Empty 4 | | Node of 'a node_data 5 | and 'a node_data = { 6 | data: 'a; 7 | prio: int; 8 | left: 'a t; 9 | right: 'a t; 10 | } 11 | 12 | let empty = Empty 13 | 14 | let is_empty = function 15 | | Empty -> true 16 | | _ -> false 17 | 18 | let rec insert prio data = function 19 | | Empty -> Node { 20 | data = data; 21 | prio = prio; 22 | left = Empty; 23 | right = Empty; 24 | } 25 | | Node n when prio < n.prio 26 | -> Node { 27 | data = data; 28 | prio = prio; 29 | left = insert n.prio n.data n.right; 30 | right = n.left; 31 | } 32 | | Node n -> Node { 33 | data = n.data; 34 | prio = n.prio; 35 | left = insert prio data n.right; 36 | right = n.left; 37 | } 38 | 39 | let peek = function 40 | | Empty -> raise Not_found 41 | | Node n -> n.data 42 | 43 | let rec remove_min = function 44 | | Empty -> raise Not_found 45 | | Node { left = Empty; right = r } -> r 46 | | Node { right = Empty; left = l } -> l 47 | | Node { left = Node l; right = Node r } -> 48 | if r.prio < l.prio then 49 | Node { 50 | data = r.data; 51 | prio = r.prio; 52 | left = Node l; 53 | right = remove_min (Node r); 54 | } 55 | else 56 | Node { 57 | data = l.data; 58 | prio = l.prio; 59 | left = remove_min (Node l); 60 | right = Node r; 61 | } 62 | 63 | -------------------------------------------------------------------------------- /lib/priorityQueue.mli: -------------------------------------------------------------------------------- 1 | (** 2 | * Purely-functional priority queues. 3 | *) 4 | 5 | (** The abtract type of a priority queue with elements of type ['a]. *) 6 | type +'a t 7 | 8 | (** The empty priority queue. *) 9 | val empty : 'a t 10 | 11 | (** Is a priority queue empty? *) 12 | val is_empty : 'a t -> bool 13 | 14 | (** Given a priority and an element, insert into a queue. *) 15 | val insert : int -> 'a -> 'a t -> 'a t 16 | 17 | (** Get the minimal value, if there is one. Raises [Not_found] if the 18 | * queue is empty. *) 19 | val peek : 'a t -> 'a 20 | 21 | (** Remove the minimal element and return the remaining queue. Raises 22 | * [Not_found] if the queue is empty. *) 23 | val remove_min : 'a t -> 'a t 24 | 25 | -------------------------------------------------------------------------------- /lib/proc.cppo.ml: -------------------------------------------------------------------------------- 1 | (* 2 | * The idea of Proc is to abstract away UNIX processes into something 3 | * more manageable from OCaml. To this end, we create abstract Proc.t 4 | * objects that we store in a weak table; a SIGCHLD handler collects the 5 | * exit status of child processes and stores them in the Proc.t objects 6 | * in this table, when possible. 7 | * 8 | * A call to Proc.wait then looks in the table for exit status (and thus 9 | * may be called more than once). If the child process hasn't exited 10 | * yet, then Proc.wait actually calls UNIX waitpid to get the exit 11 | * status. 12 | * 13 | * It's also possible to construct a Proc.t object from a pid (int) even 14 | * if the process wasn't created using this library. In this case, the 15 | * library detects whether the process is a child or not, and records 16 | * this fact in the record. We don't allow waiting on or getting the 17 | * status of non-child processes, for obvious reasons. We also take 18 | * care in Proc.fork that in the new child process, all the procs in the 19 | * table are marked as non-children, since they are siblings of the new 20 | * process. 21 | *) 22 | open Util 23 | 24 | exception Not_child 25 | 26 | type status = Unix.process_status = 27 | | WEXITED of int 28 | | WSIGNALED of int 29 | | WSTOPPED of int 30 | 31 | type t = { 32 | pid : int; 33 | mutable status : status option; 34 | mutable child : bool; 35 | } 36 | 37 | type proc = t 38 | 39 | (* In the weak table, we look up proc records just by the pid, since we 40 | * don't know ahead of time what the status will be. Thus, when we call 41 | * the helper find_pid (below) to find all procs with a given pid, we 42 | * just use dummy data for the other two fields. *) 43 | module Table = Weak.Make(struct 44 | type t = proc 45 | let hash proc = Hashtbl.hash proc.pid 46 | let equal proc1 proc2 = proc1.pid = proc2.pid 47 | end) 48 | 49 | let table = Table.create 128 50 | 51 | let find_pid pid = Table.find_all table 52 | { pid = pid; status = None; child = true } 53 | 54 | (* When a process exits and we want to record its exit status, we don't 55 | * just want the Proc.t with the right pid, but we want one that doesn't 56 | * have an exit status yet. PIDs can be recycled, but this lets us keep 57 | * our association exact (hopefully!). *) 58 | let unwaited_proc_of_pid pid = 59 | try Some (List.find (fun proc -> proc.status = None) (find_pid pid)) 60 | with Not_found -> None 61 | 62 | let stash_status pid status = 63 | match unwaited_proc_of_pid pid with 64 | | None -> () 65 | | Some proc -> proc.status <- Some status 66 | 67 | let rec wait_and_save ?(pid = -1) flags = 68 | try 69 | match Unix.waitpid flags pid with 70 | | 0, _ -> raise Not_found 71 | | pid, status -> stash_status pid status 72 | with Unix.Unix_error (Unix.EINTR, "waitpid", _) 73 | -> wait_and_save ~pid flags 74 | 75 | (* Because of what is apparenly a bug in Utop 76 | * (https://github.com/diml/utop/issues/152), we have to use [Lwt_unix.fork] 77 | * instead of [Unix.fork] in shcaml for it to work with Utop. 78 | 79 | * As a workaround, we depend optionally on lwt, and detect at compile time if 80 | * it is installed. If so, we use [Lwt_unix.fork]. 81 | *) 82 | let system_fork = 83 | #ifdef WITH_LWT 84 | Lwt_unix.fork 85 | #else 86 | Unix.fork 87 | #endif 88 | 89 | (* We need to block SIGCHLD while forking, because otherwise there's a 90 | * race condition between the child exiting and the parent adding the 91 | * child to its known process table. 92 | *) 93 | let fork () = 94 | Pervasives.flush_all (); 95 | let old_mask = Unix.sigprocmask Unix.SIG_BLOCK [Sys.sigchld] in 96 | let restore () = ignore (Unix.sigprocmask Unix.SIG_SETMASK old_mask) in 97 | let thunk () = match system_fork () with 98 | (* We should just clear the table, but we need wait and friends to know how 99 | * to handle a proc that's not in the table. *) 100 | | 0 -> Table.iter (fun proc -> proc.child <- false) table; 101 | None 102 | | pid -> let proc = { pid = pid; status = None; child = true; } in 103 | Table.add table proc; 104 | Some proc in 105 | unwind_protect thunk restore 106 | 107 | let spawn ?(quiet = false) thunk = 108 | match fork () with 109 | | Some proc -> proc 110 | | None -> try thunk (); 111 | exit 0 112 | with e -> 113 | if not quiet 114 | then Printf.eprintf "Uncaught exception: %s\n" 115 | (Printexc.to_string e); 116 | exit 2 117 | 118 | (* 119 | * The SIGCHLD handler does non-hanging waits as many times as 120 | * necessary, stashing each result in the table, and then resets itself. 121 | *) 122 | let rec handle_sigchld num = 123 | try while true do 124 | wait_and_save [Unix.WNOHANG] 125 | done with 126 | | Unix.Unix_error (Unix.ECHILD, "waitpid", _) 127 | | Not_found -> 128 | Sys.set_signal num (Sys.Signal_handle handle_sigchld) 129 | 130 | let autoreap () = handle_sigchld Sys.sigchld 131 | let don't_autoreap () = Sys.set_signal Sys.sigchld Sys.Signal_default 132 | 133 | let rec wait proc = 134 | if not proc.child then raise Not_child; 135 | match proc.status with 136 | | Some status -> status 137 | | None -> 138 | (try wait_and_save ~pid:proc.pid [] with 139 | | Unix.Unix_error (Unix.ECHILD, _, _) -> 140 | if proc.status = None 141 | then raise Not_found); 142 | wait proc 143 | 144 | let status_of_proc proc = 145 | if not proc.child then raise Not_child; 146 | (try wait_and_save ~pid:proc.pid [Unix.WNOHANG] with 147 | | Unix.Unix_error (Unix.ECHILD, "waitpid", _) | Not_found -> ()); 148 | proc.status 149 | 150 | let is_child proc = proc.child 151 | let pid_of_proc proc = proc.pid 152 | 153 | let wait_any procs = 154 | if procs = [] || List.exists (not % is_child) procs 155 | then raise Not_child; 156 | let old_mask = Unix.sigprocmask Unix.SIG_BLOCK [Sys.sigchld] in 157 | unwind_protect 158 | (fun _ -> 159 | while_none 160 | (fun _ -> find' (fun proc -> proc.status <> None) procs) 161 | (fun _ -> try 162 | let pid, status = Unix.wait () in 163 | stash_status pid status 164 | with Unix.Unix_error (Unix.EINTR, _, _) -> () 165 | ) 166 | ) 167 | (fun _ -> Unix.sigprocmask Unix.SIG_SETMASK old_mask) 168 | 169 | (* This is kind of complicated. First, we look up the list of any procs 170 | * we already know about. Then, if and ONLY if all the procs we know 171 | * about have terminated, we search for any running processes that we 172 | * don't know about. First, we try waiting on it -- if these succeeds, 173 | * then we know it's a child, and we add it to the table. (We store the 174 | * status if it's exited, but note that this case can happen only if 175 | * autoreaping is off; if it's on, the process will be reaped already.) 176 | * If it's not a child, we check if it exists at all, and if so, we 177 | * create a non-child Proc.t to represent it. If we succeed in finding 178 | * an unknown process either way, it becomes known and is added to the 179 | * returned list. 180 | *) 181 | let procs_of_pid pid = 182 | if pid < 1 then raise (Invalid_argument "procs_of_pid"); 183 | let package_up res = 184 | let proc = match res with 185 | | -1, _ -> { pid = pid; status = None; child = false; } 186 | | 0, _ -> { pid = pid; status = None; child = true; } 187 | | _, s -> { pid = pid; status = Some s; child = true; } in 188 | Table.add table proc; 189 | proc in 190 | let possibilities = find_pid pid in 191 | if List.exists (fun proc -> proc.status = None) possibilities 192 | then possibilities 193 | else 194 | try package_up (Unix.waitpid [Unix.WNOHANG] pid) :: possibilities 195 | with Unix.Unix_error (Unix.ECHILD, "waitpid", _) -> 196 | try Unix.kill pid 0; 197 | package_up (-1, Unix.WEXITED 0) :: possibilities 198 | with Unix.Unix_error ((Unix.ESRCH | Unix.EPERM), "kill", _) 199 | -> possibilities 200 | 201 | let proc_of_pid pid = match procs_of_pid pid with 202 | | [] -> raise Not_found 203 | | proc::__ -> proc 204 | 205 | let kill ?(raise = true) signal proc = 206 | try Unix.kill proc.pid signal with 207 | | Unix.Unix_error ((Unix.ESRCH | Unix.EPERM), "kill", _) 208 | when not raise -> () 209 | 210 | let exit_with_status = function 211 | | WEXITED n -> 212 | exit n 213 | | WSIGNALED n -> 214 | Sys.set_signal n Sys.Signal_default; 215 | Unix.kill n (Unix.getpid ()); 216 | exit (-1) 217 | | _ -> 218 | exit 0 219 | 220 | type execspec = { path: bool option; 221 | program: string; 222 | argv0: string option; 223 | args: string list; } 224 | 225 | let with_execspec s kont = 226 | kont ?path:s.path s.program ?argv0:s.argv0 s.args 227 | 228 | let execspec ?path program ?argv0 args = 229 | { path = path; 230 | program = program; 231 | argv0 = argv0; 232 | args = args; } 233 | 234 | let exec_program ?(path = true) prog ?(argv0 = prog) args = 235 | (if path then Unix.execvp else Unix.execv) prog 236 | (Array.of_list (argv0 :: args)) 237 | 238 | let exec cmd = exec_program ~path:false "/bin/sh" ["-c"; cmd] 239 | 240 | let vfork_program ?path prog ?argv0 args = 241 | IVar.with_interprocess_protect @@ fun protect -> 242 | spawn (fun _ -> protect (fun _ -> exec_program ?path prog ?argv0 args)) 243 | 244 | let vfork cmd = vfork_program ~path:false "/bin/sh" ["-c"; cmd] 245 | 246 | let system_program ?path prog ?argv0 args = 247 | wait (vfork_program ?path prog ?argv0 args) 248 | 249 | let system cmd = wait (vfork cmd) 250 | 251 | let pp fmt proc = 252 | Format.fprintf fmt "" (pid_of_proc proc) 253 | (if is_child proc 254 | then match status_of_proc proc with 255 | | None -> "running" 256 | | Some (Unix.WEXITED n) -> Format.sprintf "exited:%d" n 257 | | Some (Unix.WSIGNALED n) -> Format.sprintf "signaled:%d" n 258 | | Some (Unix.WSTOPPED n) -> Format.sprintf "stopped:%d" n 259 | else "non-child") 260 | 261 | (* Autoreaping is on be default. *) 262 | let _ = autoreap () 263 | -------------------------------------------------------------------------------- /lib/proc.mli: -------------------------------------------------------------------------------- 1 | (** An OCaml abstraction for UNIX processes. 2 | The {!Proc} module takes responsiblity for reaping 3 | children and provides access to exit codes through abstract 4 | {!Proc.t} objects. (If you need to reap yourself, 5 | {!Proc.don't_autoreap} will turn off the [Sys.sigchld] handler, and 6 | {!Proc.autoreap} will turn it back on.) 7 | 8 | Because the {!Proc} module is responsible for reaping, it makes 9 | exit status available as many times as necessary, though 10 | {!Proc.wait} and {!Proc.status_of_proc}. 11 | 12 | It's also possible to construct a {!Proc.t} object from a pid 13 | ([int]) even if the process wasn't created using this library. In 14 | this case, the library detects whether the process is a child or 15 | not. We don't allow waiting 16 | on or getting the status of non-child processes, because UNIX 17 | doesn't. 18 | 19 | Much of this design is due to Cash/Scsh. 20 | *) 21 | 22 | 23 | (** 24 | {1 Types} 25 | *) 26 | 27 | (** Raised on attempts to get the exit status of a process that 28 | isn't a child of the current process *) 29 | exception Not_child 30 | 31 | (** The abstract type of a process representation *) 32 | type t 33 | 34 | (** Alias for [Unix.process_status] *) 35 | type status = Unix.process_status = 36 | | WEXITED of int 37 | (** The process terminated normally by exit; the argument is the 38 | return code. *) 39 | | WSIGNALED of int 40 | (** The process was killed by a signal; the argument is the 41 | signal number. *) 42 | | WSTOPPED of int 43 | (** The process was stopped by a signal; the argument is the 44 | signal number. *) 45 | 46 | (** 47 | {1 Process Management} 48 | *) 49 | 50 | (** Return [Some t] in the parent and [None] in the child *) 51 | val fork : unit -> t option 52 | 53 | (** Run a thunk in a subprocess, returning its {!Proc.t}. {!spawn} 54 | will not allow control in the subprocess to return to its caller; to 55 | this end, it catches all exceptions, printing a message and then 56 | exiting with status 2. The optional argument [?quiet] (default 57 | false) suppresses the message. *) 58 | val spawn : ?quiet:bool -> (unit -> unit) -> t 59 | 60 | (** Send a signal to a process. [Proc.kill n p] sends signal [n] 61 | to process [p]. The optional argument [?raise] (default [true]) 62 | specifies whether to raise an exception if the process doesn't 63 | exist or we aren't allowed to kill it. 64 | 65 | Raises [Unix.Unix_error] (see [Unix.kill]) 66 | *) 67 | val kill : ?raise:bool -> int -> t -> unit 68 | 69 | (** [Proc.wait proc] performs a blocking wait on [proc]; 70 | if the child has already exited, it returns immediately. 71 | Unlike [Unix.waitpid], [Proc.wait] may 72 | be called multiple times for the same process. If [proc] is not a child 73 | of the calling process, raises {!Not_child}. *) 74 | val wait : t -> status 75 | 76 | (** Given a list of [Proc.t]s, return any one of them that has exited. 77 | If one has exited already, it return immediately, but if all are still 78 | running, it blocks. Calling {!Proc.wait_any} may reap children 79 | other than those in the list. 80 | 81 | Raises [Not_child] if given the empty list or any non-children. *) 82 | val wait_any : t list -> t 83 | 84 | (** Retrieve the status of a process if it has exited; non-blocking. 85 | Raises {!Not_child} if [proc] is not a child of the calling 86 | process. *) 87 | val status_of_proc : t -> status option (* raises Not_child *) 88 | 89 | (** Is a process a child of the calling process? *) 90 | val is_child : t -> bool 91 | 92 | (** The UNIX process ID associated with [proc] *) 93 | val pid_of_proc : t -> int 94 | 95 | (** Find or create a {!Proc.t} associated with a UNIX 96 | process. If there is no {!t} but the process exists, it constructs 97 | one. Raises [Not_found] if there is no process with the given process id, 98 | or [Invalid_argument "procs_of_pid"] if the pid is non-positive. 99 | *) 100 | val proc_of_pid : int -> t (* raises Not_found *) 101 | 102 | (** Returns a list of all {!Proc.t}s with the given process id. 103 | There may be more than one if the same process id has been used 104 | multiple times (rarely). *) 105 | val procs_of_pid : int -> t list 106 | 107 | 108 | (** Exit with the given exit status. If the status indicates a 109 | signal, this function sets the default signal handler and signals 110 | the current process. *) 111 | val exit_with_status : status -> 'a 112 | 113 | (** 114 | {2 Autoreaping} 115 | *) 116 | 117 | (** Turn on autoreaping of processes. When set, Shcaml will 118 | automatically wait on processes and store their exit status 119 | for retrieval by {!wait} or {!status_of_proc}. *) 120 | val autoreap : unit -> unit 121 | 122 | (** Turn off autoreaping of processes. If autoreaping is disabled, 123 | {!wait} and {!status_of_proc} will still work, but the user is 124 | responsible to reap all processes. *) 125 | val don't_autoreap : unit -> unit 126 | 127 | (** 128 | {1 Running Programs} 129 | *) 130 | 131 | (** Run a command and wait for it to exit. 132 | Passes the command to the shell for parsing. 133 | If the shell cannot be found or run, raises 134 | the same exceptions as [Unix.execv]. 135 | 136 | This function delegates to the shell for argument parsing; if you 137 | already have a list, use {!system_program}. 138 | *) 139 | val system : string -> status 140 | 141 | (** Run a program with arguments and wait for it to exit. 142 | Optional argument [?path] (default [true]) specifies whether 143 | to search the path, and [?argv0] (default [prog]) specifies 144 | an alternate value for the new process's [argv.(0)]. 145 | 146 | If [Unix.execv] raises an exception in the child process, 147 | [Proc.system_program] re-raises the exception on the parent process. 148 | 149 | This function takes an already-parsed argument list. To have the 150 | shell do it, use {!system}. 151 | *) 152 | val system_program : ?path:bool -> string -> 153 | ?argv0:string -> string list -> status 154 | 155 | (** Run a command asynchonously. Like {!system}, but doesn't wait. *) 156 | val vfork : string -> t 157 | 158 | (** Run a program asynchonously. Like {!system_program}, but doesn't wait. *) 159 | val vfork_program : ?path:bool -> string -> 160 | ?argv0:string -> string list -> t 161 | 162 | (** Replace the current process image with a command. 163 | Like {!vfork}, but doesn't fork. *) 164 | val exec : string -> 'a 165 | 166 | (** Replace the current process image with another. 167 | Like {!vfork_program}, but doesn't fork. *) 168 | val exec_program : ?path:bool -> string -> 169 | ?argv0:string -> string list -> 'a 170 | 171 | (** 172 | * {2 The [execspec] Record. } 173 | *) 174 | 175 | (** Several Shcaml functions (such as {!exec_program} and 176 | {!system_program}) take the same arguments to specify a 177 | program to execute. It's sometimes 178 | helpful to package these arguments in a record and pass them to such 179 | a function later. *) 180 | type execspec = { path: bool option; 181 | (** Search the path (default [true]) *) 182 | program: string; 183 | (** Executable to run *) 184 | argv0: string option; 185 | (** Zeroth argument (default [program]) *) 186 | args: string list; 187 | (** Additional arguments *) 188 | } 189 | 190 | (** Constructs an {!execspec}, given the same arguments as 191 | * {!exec_program}. *) 192 | val execspec : ?path:bool -> string -> 193 | ?argv0:string -> string list -> 194 | execspec 195 | 196 | (** Call a function with a given {!execspec}. 197 | For example, 198 | [Proc.with_execspec (Proc.execspec ~path program ~argv0 args) f] calls 199 | [f ~path program ~argv0 args]. *) 200 | val with_execspec : execspec -> 201 | (?path:bool -> string -> 202 | ?argv0:string -> string list -> 'a) -> 203 | 'a 204 | 205 | (** 206 | {1 Pretty-printing} 207 | *) 208 | 209 | val pp : Format.formatter -> t -> unit 210 | (** Pretty-printer for {!Proc.t}. *) 211 | -------------------------------------------------------------------------------- /lib/reader.ml: -------------------------------------------------------------------------------- 1 | open Util 2 | 3 | type raw_line = { 4 | content : string; 5 | before : string; 6 | after : string; 7 | } 8 | 9 | let raw_of_string ?(before="") ?(after = "\n") s = { 10 | content = s; 11 | before = before; 12 | after = after; 13 | } 14 | 15 | type t = in_channel -> raw_line 16 | 17 | let lines = raw_of_string % input_line 18 | (* This adds \n to the end of the last line even if the 19 | input ends without a newline *) 20 | 21 | let rec buf_span buf pred start limit = 22 | if start < limit && pred (Buffer.nth buf start) 23 | then buf_span buf pred (start + 1) limit 24 | else start 25 | 26 | let rec buf_rspan buf pred start limit = 27 | if limit > start && pred (Buffer.nth buf (limit - 1)) 28 | then buf_rspan buf pred start (limit - 1) 29 | else limit 30 | 31 | let set_helper set ~eof buf = 32 | let pred = String.contains set in 33 | let limit = Buffer.length buf in 34 | if eof then 35 | let pre = buf_span buf pred 0 limit in 36 | let post = buf_rspan buf pred pre limit in 37 | Some { content = Buffer.sub buf pre (post - pre); 38 | before = Buffer.sub buf 0 pre; 39 | after = Buffer.sub buf post (limit - post); } 40 | else if limit > 1 && 41 | pred (Buffer.nth buf (limit - 1)) && 42 | not (pred (Buffer.nth buf (limit - 2))) then 43 | let pre = buf_span buf pred 0 limit in 44 | Some { content = Buffer.sub buf pre (limit - pre - 1); 45 | before = Buffer.sub buf 0 pre; 46 | after = Buffer.sub buf (limit - 1) 1; } 47 | else None 48 | 49 | let rec make = 50 | function 51 | | `Char chr -> fun c -> 52 | let buf = Buffer.create 80 in 53 | let rec loop () = 54 | match input_char c with 55 | | x when (x <> chr) -> Buffer.add_char buf x; loop () 56 | | x -> { content = Buffer.contents buf; 57 | before = ""; 58 | after = String.make 1 x } in 59 | (try loop () 60 | with End_of_file when Buffer.length buf <> 0 61 | -> { content = Buffer.contents buf; 62 | before = ""; 63 | after = ""; }) 64 | | `Set set -> make (`Buf (set_helper set)) 65 | | `Fixed (n, m) -> fun c -> 66 | let content = Bytes.make n '\000' in 67 | let after = Bytes.make m '\000' in 68 | Pervasives.really_input c content 0 n; 69 | ignore @@ Pervasives.input c after 0 n; 70 | { content = Bytes.unsafe_to_string content; 71 | before = ""; 72 | after = Bytes.unsafe_to_string after; } 73 | | `Buf f -> fun c -> 74 | let buf = Buffer.create 80 in 75 | let rec loop () = 76 | Buffer.add_char buf (input_char c); 77 | match f ~eof:false buf with 78 | | None -> loop () 79 | | Some rl -> rl in 80 | try loop () 81 | with End_of_file as e when Buffer.length buf <> 0 82 | -> match f ~eof:true buf with 83 | | None -> raise e 84 | | Some rl -> rl 85 | 86 | let rec ignore_if pred reader c = 87 | let rl = reader c in 88 | if pred rl.content 89 | then ignore_if pred reader c 90 | else rl 91 | 92 | (* This could be optimized, but it's not necessary unless there are 93 | * lines that get continued many times. *) 94 | let join_on character reader c = 95 | let rec loop this = 96 | let length = String.length this.content in 97 | if this.content.[length - 1] = character 98 | then let next = reader c in 99 | loop { before = this.before; 100 | content = String.sub this.content 0 (length - 1) ^ next.content; 101 | after = next.after; } 102 | else this in 103 | loop (reader c) 104 | 105 | let empty = (=) "" 106 | 107 | let contains ?(regexp=false) pat = 108 | let rex = Pcre.regexp (if regexp then pat else Pcre.quote pat) in 109 | fun str -> Pcre.pmatch ~rex str 110 | 111 | let blank = contains ~regexp:true "^\\s*$" 112 | 113 | let starts_with pat = contains ~regexp:true ("^\\s*" ^ Pcre.quote pat) 114 | let ends_with pat = contains ~regexp:true (Pcre.quote pat ^ "\\s*$") 115 | -------------------------------------------------------------------------------- /lib/reader.mli: -------------------------------------------------------------------------------- 1 | (** Readers are responsible for breaking input data into pieces, or 2 | "raw lines". A [Reader.t] need not be concerned with the meaning of 3 | data {i in} a line. Its goal is merely to determine boundaires. Given 4 | an [in_channel] from which to read, a reader reads some data, and 5 | produces a [Reader.raw_line] record. It should keep track of any 6 | non-data (formatting or record separators) that it encounters, using 7 | the [before] and [after] fields, making its operation somewhat 8 | invertible. 9 | *) 10 | 11 | (** An raw line as returned by a reader *) 12 | type raw_line = { 13 | content : string; (** The data of the line *) 14 | before : string; (** Delimiting text from before the data *) 15 | after : string; (** Delimiting text from after the data *) 16 | } 17 | 18 | (** The type of a reader. A reader extracts {!raw_line}s from an input 19 | * channel. *) 20 | type t = in_channel -> raw_line 21 | 22 | (** Construct an raw line from its contents. The optional 23 | * parameter [?before] defaults to [""] and [?after] defaults to 24 | * ["\n"]. *) 25 | val raw_of_string : ?before:string -> ?after:string -> string -> raw_line 26 | 27 | (** Construct a reader with a predefined behavior. 28 | * - [`Char c] means that raw lines are terminated by the character [c]. 29 | * - [`Set s] means that raw lines are separated by a sequence of one or 30 | * more characters from the string [s]. Line separator characters may 31 | * be returned in either the preceding or following {!raw_line}. 32 | * - [`Fixed (n, m)] means that raw lines comprise [n] characters of data 33 | * followed by [m] characters of garbage. 34 | * - [`Buf f] uses the function [f] to determine whether the input 35 | * buffer contains a complete raw line. If [f] returns [Some r], then [r] 36 | * is returns the buffer is flushed; otherwise, one more character is 37 | * read and then [f] is tried again. At end-of-file, [f] is passed 38 | * [~eof:true]. 39 | * 40 | * Readers constructed by {!make} are stateless between calls. 41 | * *) 42 | val make : [ `Char of char 43 | | `Set of string 44 | | `Fixed of int * int 45 | | `Buf of eof:bool -> Buffer.t -> raw_line option ] 46 | -> t 47 | 48 | (** Read newline-terminated raw lines. If the last line is not 49 | * newline-terminated, a newline is stored in the trailing delimiter 50 | * nonetheless. *) 51 | val lines : t 52 | 53 | (** {2 Reader Transformers} 54 | 55 | Reader transformers add behavior to a reader. *) 56 | 57 | val ignore_if : (string -> bool) -> t -> t 58 | (** Ignore raw lines satisfying a string predicate. Given a predicate and 59 | * a reader, returns a new reader that skips lines whose content 60 | * satisfies the predicate. *) 61 | val join_on : char -> t -> t 62 | (** Read raw lines with a line continuation character. If a line 63 | * ends with the given character, the character will be removed and the 64 | * next line will be concatenated. *) 65 | 66 | val empty : string -> bool 67 | (** Predicate for empty strings. *) 68 | val blank : string -> bool 69 | (** Predicate for empty or white space strings. *) 70 | val starts_with : string -> string -> bool 71 | (** Predicate for strings starting with a given string. 72 | * [starts_with patt s] returns whether [s] starts with the string [patt]. 73 | * Allows additional leading white space in the subject string. 74 | *) 75 | val ends_with : string -> string -> bool 76 | (** Predicate for strings ending with a given string. 77 | * [ends_with patt s] returns whether [s] ends with the string [patt]. 78 | * Allows additional trailing white space in the subject string. 79 | *) 80 | val contains : ?regexp:bool -> string -> string -> bool 81 | (** Predicate for strings containing a given pattern. 82 | * [contains patt s] returns whether the string [s] contains the 83 | * {i string} [patt]. Calling [contains ~regexp:true patt s] 84 | * returns whether the string [s] matches the Perl-compatible regular 85 | * expression [patt]. 86 | *) 87 | -------------------------------------------------------------------------------- /lib/shcaml.mllib: -------------------------------------------------------------------------------- 1 | Shcaml 2 | 3 | -------------------------------------------------------------------------------- /lib/shcaml.mlpack: -------------------------------------------------------------------------------- 1 | Flags 2 | Util 3 | Version 4 | WeakPlus 5 | PriorityQueue 6 | Signal 7 | Reader 8 | Delimited 9 | IVar 10 | Abort 11 | Disposal 12 | Proc 13 | Line 14 | Channel 15 | Shtream 16 | AnyShtream 17 | StringShtream 18 | LineShtream 19 | Fitting 20 | FittingSig 21 | Adaptor 22 | DepDAG 23 | UsrBin 24 | -------------------------------------------------------------------------------- /lib/shcaml_top.ml: -------------------------------------------------------------------------------- 1 | (* A very quiet formatter. *) 2 | let silently = Format.make_formatter (fun _ _ _ -> ()) ignore 3 | 4 | let () = 5 | Topdirs.dir_use silently "shcaml_top_init.ml"; 6 | if !Sys.interactive 7 | then Printf.printf "\tCaml-Shcaml version %s (%s)\n\n%!" 8 | Shcaml.Version.version Shcaml.Version.version_name 9 | -------------------------------------------------------------------------------- /lib/shcaml_top.mllib: -------------------------------------------------------------------------------- 1 | Shcaml_top -------------------------------------------------------------------------------- /lib/shcaml_top_init.ml: -------------------------------------------------------------------------------- 1 | (* 2 | * Loaded by shcaml.top; installs printers and opens common modules 3 | * interactive use. 4 | *) 5 | 6 | open Shcaml;; 7 | open Util;; 8 | open UsrBin;; 9 | open Fitting;; 10 | open Channel.Dup;; 11 | 12 | #install_printer Line.pp;; 13 | #install_printer Channel.pp_descr;; 14 | #install_printer Proc.pp;; 15 | #install_printer Channel.pp_in_channel;; 16 | #install_printer Channel.pp_out_channel;; 17 | -------------------------------------------------------------------------------- /lib/shtream.ml: -------------------------------------------------------------------------------- 1 | (* vim: set ft=ocaml : *) 2 | open Util 3 | open Channel 4 | 5 | (* *) 6 | 7 | exception Failure 8 | 9 | exception FailWith of Proc.status 10 | exception TryAgain 11 | exception Warning of string 12 | 13 | (* 14 | * Representation 15 | *) 16 | type 'a data = 17 | | Strict of 'a * 'a data 18 | | Delay of (unit -> 'a data) 19 | | Extern of in_channel 20 | | TheEnd of Proc.status 21 | 22 | type 'a t = { 23 | mutable data: 'a data; 24 | mutable read: in_channel -> 'a; 25 | mutable hint: (Reader.raw_line -> 'a) option; 26 | mutable close: unit -> unit; 27 | mutable procref: procref option; 28 | mutable protect: 'b . (unit -> 'b) -> 'b; 29 | } 30 | 31 | type protector = Util.protector 32 | let null_protect f = f () 33 | let null_protect_rec = { protector = null_protect; } 34 | 35 | (* 36 | * Stream initialization and finalization 37 | *) 38 | 39 | let make ?(read = (fun _ -> raise Bug)) 40 | ?(hint = None) 41 | ?(close = ignore) 42 | ?procref 43 | ?(protect = null_protect_rec) 44 | data = 45 | { data = data; 46 | read = read; 47 | hint = hint; 48 | close = close; 49 | procref = procref; 50 | protect = protect.protector; } 51 | 52 | (* 53 | * Public functions (from Stream) 54 | *) 55 | 56 | (* We keep the position in a ref cell rather than passing it along 57 | * functionally because Shtream.force (below) will call our thunk 58 | * multiple times if TryAgain is raised, and we want the index to 59 | * advance on retries. *) 60 | let from_low ?close f = 61 | let position = ref 0 in 62 | let n () = 63 | let it = !position in 64 | position := it + 1; 65 | it 66 | in 67 | let rec loop = Delay (fun _ -> Strict (f (n ()), loop)) in 68 | make ?close loop 69 | 70 | let from f = 71 | from_low (fun n -> maybe (f n) (fun _ -> raise Failure) id) 72 | 73 | let try_again () = raise TryAgain 74 | let warn fmt = Printf.ksprintf (fun s -> raise (Warning s)) fmt 75 | let fail_with n = raise (FailWith n) 76 | 77 | let end_success = TheEnd (Proc.WEXITED 0) 78 | 79 | let close s = 80 | (match s.data with 81 | | TheEnd _ -> () 82 | | _ -> s.data <- end_success); 83 | s.close (); 84 | s.close <- ignore 85 | 86 | let set_reader s r = 87 | s.read <- r; 88 | s.hint <- None 89 | 90 | let hint_reader s r = 91 | match s.hint with 92 | | Some h -> s.read <- h % r 93 | | _ -> () 94 | 95 | let add_protection protector s = 96 | if s.protect == null_protect 97 | then s.protect <- protector.protector 98 | else s.protect <- let old = s.protect in 99 | fun thunk -> protector.protector (fun _ -> old thunk) 100 | 101 | let add_cleanup close s = 102 | if s.close == ignore 103 | then s.close <- close 104 | else s.close <- let old = s.close in (fun _ -> old (); close ()) 105 | 106 | let of_list lst = 107 | make (List.fold_right (fun x y -> Strict (x, y)) lst end_success) 108 | 109 | let of_channel ?hint read c = 110 | let c = dup_in (`InChannel c) in 111 | make ~read ~close:(fun _ -> close_in c) ~hint (Extern c) 112 | 113 | let of_stream stream = 114 | let rec loop = Delay (fun () -> 115 | try Strict (Stream.next stream, loop) 116 | with Stream.Failure -> end_success) in 117 | make loop 118 | 119 | (* Error handling *) 120 | 121 | type error_handler = [`Warning of string | `Exception of exn] -> unit 122 | 123 | let string_of_shtream_error = function 124 | | `Warning w -> w 125 | | `Exception e -> Printexc.to_string e 126 | 127 | let ignore_errors = ignore 128 | 129 | let warn_on_errors e = 130 | Printf.eprintf "%s: shtream warning: %s\n%!" Sys.argv.(0) 131 | @@ string_of_shtream_error e 132 | 133 | let die_on_errors e = 134 | Printf.eprintf "%s: shtream error: %s\n%!" Sys.argv.(0) 135 | @@ string_of_shtream_error e; 136 | fail_with (Proc.WEXITED (-1)) 137 | 138 | let die_silently_on_errors _ = fail_with (Proc.WEXITED (-1)) 139 | 140 | let current_error_handler = ref warn_on_errors 141 | 142 | (* Shtream evaluation *) 143 | 144 | (* When called with N >= 0, will produce a shtream with N 145 | * Stricts in front or fewer than N followed by TheEnd. *) 146 | module Force = struct 147 | let end_of_procref = function 148 | | Some {contents = Some proc} -> begin 149 | match Proc.status_of_proc proc with 150 | | Some s -> TheEnd s 151 | | _ -> end_success 152 | end 153 | | _ -> end_success 154 | 155 | let call_error_handler = function 156 | | Warning s -> !current_error_handler (`Warning s) 157 | | e -> !current_error_handler (`Exception e) 158 | 159 | let finish s = 160 | close s; 161 | let it = 162 | end_of_procref s.procref in 163 | s.procref <- None; 164 | it 165 | 166 | let finish_with n s = 167 | close s; 168 | s.procref <- None; 169 | TheEnd n 170 | 171 | let handle s retry = function 172 | | End_of_file 173 | | Failure -> finish s 174 | | FailWith m -> finish_with m s 175 | | TryAgain -> retry 176 | (* Some exceptions should be passed upward. What others? *) 177 | | Sys.Break as e 178 | -> raise e 179 | | e -> 180 | try call_error_handler e; retry with 181 | | Failure -> finish s 182 | | FailWith m -> finish_with m s 183 | | TryAgain -> retry 184 | 185 | let rec loop s n d = match d with 186 | | _ when n = 0 -> d 187 | | Strict (x, y) -> Strict (x, loop s (n - 1) y) 188 | | Delay f -> loop s n (try s.protect f with 189 | | e -> handle s d e) 190 | | Extern c -> loop s n (try Strict (s.read c, d) with 191 | | e -> handle s d e) 192 | | TheEnd n -> close s; TheEnd n 193 | 194 | let force n s = s.data <- loop s n s.data 195 | end 196 | 197 | let force = Force.force 198 | 199 | let npeek ?(n = 1) s = 200 | let rec loop n d = match d with 201 | | _ when n = 0 -> [] 202 | | Strict (x, y) -> x :: loop (n - 1) y 203 | | TheEnd _ -> [] 204 | | _ -> raise Bug 205 | in force n s; 206 | loop n s.data 207 | 208 | let peek ?(n = 0) s = 209 | let rec loop n d = match d with 210 | | Strict (r, _) when n = 0 -> Some r 211 | | Strict (_, y) -> loop (n - 1) y 212 | | TheEnd _ -> None 213 | | _ -> raise Bug 214 | in force (n + 1) s; 215 | loop n s.data 216 | 217 | let junk ?(n = 1) s = 218 | let rec loop n d = match d with 219 | | _ when n = 0 -> d 220 | | Strict (_, y) -> loop (n - 1) y 221 | | TheEnd _ -> d 222 | | _ -> raise Bug 223 | in force n s; 224 | s.data <- loop n s.data 225 | 226 | let next s = match peek s with 227 | | Some r -> junk s; r 228 | | None -> raise Failure 229 | 230 | let next' s = match peek s with 231 | | r -> junk s; r 232 | 233 | let empty s = match next' s with 234 | | None -> () 235 | | _ -> raise Failure 236 | 237 | let is_empty s = match next' s with 238 | | None -> true 239 | | _ -> false 240 | 241 | let status s = 242 | ignore (peek s); 243 | match s.data with 244 | | TheEnd n -> Some n 245 | | _ -> None 246 | 247 | let insert element s = 248 | s.data <- Strict (element, s.data) 249 | 250 | let cons element s = 251 | insert element s; 252 | s 253 | 254 | let nil () = make end_success 255 | 256 | let rec iter f s = match next' s with 257 | | Some r -> f r; iter f s 258 | | None -> () 259 | 260 | (* 261 | * Public functions (new to Shtream) 262 | *) 263 | 264 | (* To enforce (dynamic) linearity of shtreams, this function creates 265 | * a copy of s and then empties s. *) 266 | let claim s = 267 | let s' = { s with read = s.read } in 268 | s.data <- end_success; 269 | s' 270 | 271 | let append s1 s2 = 272 | let s1, s2 = claim s1, claim s2 in 273 | from_low ~close:(fun _ -> close s1; close s2) 274 | (fun _ -> match next' s1 with 275 | | None -> next s2 276 | | Some r -> r) 277 | 278 | let filter pred s = 279 | let s = claim s in 280 | let rec each n = 281 | let x = next s in 282 | if pred x then x else each n in 283 | from_low ~close:(fun _ -> close s) each 284 | 285 | let map trans s = 286 | let s = claim s in 287 | from_low ~close:(fun _ -> close s) (fun _ -> trans (next s)) 288 | 289 | let concat_map trans s = 290 | let rec data = Delay (fun _ -> 291 | List.fold_right (fun x y -> Strict (x, y)) (trans (next s)) data 292 | ) in 293 | make ~close:(fun _ -> close s) data 294 | 295 | let partition pred left right = 296 | map (fun x -> if pred x then left x else right x) 297 | 298 | let rec fold_left f z s = 299 | match next' s with 300 | | None -> z 301 | | Some x -> fold_left f (f z x) s 302 | 303 | let rec fold_right f s z = 304 | match next' s with 305 | | None -> z 306 | | Some x -> f x (lazy (fold_right f s z)) 307 | 308 | let stream_of s = 309 | let s = claim s in 310 | Stream.from (fun _ -> next' s) 311 | 312 | let list_of s = 313 | let rec loop acc = match next' s with 314 | | Some x -> loop (x :: acc) 315 | | None -> acc in 316 | List.rev (loop []) 317 | 318 | let channel_of ?procref ?(before = ignore) ?(after = ignore) write s = 319 | let rec loop = function 320 | | Extern c -> dup_in (`InChannel c) 321 | | Delay f -> loop (f ()) 322 | | data -> 323 | s.data <- data; 324 | open_thunk_in ?procref (fun _ -> 325 | before (); 326 | flush stdout; 327 | iter (fun each -> 328 | write each; 329 | flush stdout) s; 330 | after (); 331 | flush stdout; 332 | match status s with 333 | | Some n -> Proc.exit_with_status n 334 | | _ -> exit 0 335 | ) in 336 | let result = loop s.data in 337 | close s; 338 | result 339 | 340 | let of_channel_with_close ?hint reader c = 341 | unwind_protect 342 | (fun _ -> of_channel ?hint reader c) 343 | (fun _ -> close_in c) 344 | 345 | let of_file ?hint reader filename = 346 | of_channel_with_close ?hint reader (open_file_in filename) 347 | 348 | let of_command ?(procref = ref None) ?dups ?hint reader command = 349 | let it = 350 | of_channel_with_close ?hint reader 351 | (open_command_in ~procref ?dups command) in 352 | it.procref <- Some procref; 353 | it 354 | 355 | let of_program ?(procref = ref None) ?dups ?hint reader 356 | ?path prog ?argv0 args = 357 | let it = 358 | of_channel_with_close ?hint reader 359 | (open_program_in ~procref ?dups ?path prog ?argv0 args) in 360 | it.procref <- Some procref; 361 | it 362 | 363 | 364 | let of_thunk ?(procref = ref None) ?dups ?hint reader thunk = 365 | let it = 366 | of_channel_with_close ?hint reader 367 | (open_thunk_in ~procref ?dups thunk) in 368 | it.procref <- Some procref; 369 | it 370 | 371 | exception CoFailure 372 | 373 | type 'a co_t = out_channel 374 | 375 | let coshtream_of ?procref consumer = 376 | open_thunk_out ?procref 377 | (fun _ -> 378 | let each _ = try Marshal.from_channel stdin 379 | with End_of_file -> raise Failure in 380 | consumer (from_low each); 381 | exit 0) 382 | 383 | let conil = null_out 384 | 385 | let unsafe_conext c v = 386 | let buf = Marshal.to_string v [Marshal.Closures] in 387 | output_string c buf; 388 | flush c 389 | 390 | let sigpipe_protect thunk = 391 | Signal.signal_protect Sys.sigpipe ~exn:CoFailure thunk 392 | 393 | let conext c v = 394 | sigpipe_protect (fun _ -> unsafe_conext c v) 395 | 396 | let coclose c = 397 | try sigpipe_protect (fun _ -> close_out c) 398 | with CoFailure -> () 399 | 400 | let annihilate shtream coshtream = 401 | begin 402 | try sigpipe_protect (fun _ -> iter (unsafe_conext coshtream) shtream;) 403 | with CoFailure -> () 404 | end 405 | 406 | module type COMMON = sig 407 | type 'a t 408 | type 'a co_t 409 | exception Failure 410 | exception CoFailure 411 | 412 | val from : (int -> 'a option) -> 'a t 413 | val close : 'a t -> unit 414 | val of_list : 'a list -> 'a t 415 | val list_of : 'a t -> 'a list 416 | val of_stream : 'a Stream.t -> 'a t 417 | val stream_of : 'a t -> 'a Stream.t 418 | val npeek : ?n:int -> 'a t -> 'a list 419 | val peek : ?n:int -> 'a t -> 'a option 420 | val empty : 'a t -> unit 421 | val is_empty : 'a t -> bool 422 | val status : 'a t -> Proc.status option 423 | val junk : ?n:int -> 'a t -> unit 424 | val next : 'a t -> 'a 425 | val next' : 'a t -> 'a option 426 | val iter : ('a -> unit) -> 'a t -> unit 427 | val filter : ('a -> bool) -> 'a t -> 'a t 428 | val map : ('a -> 'b) -> 'a t -> 'b t 429 | val concat_map : ('a -> 'b list) -> 'a t -> 'b t 430 | val fold_left : ('b -> 'a -> 'b) -> 'b -> 'a t -> 'b 431 | val fold_right : ('a -> 'b Lazy.t -> 'b) -> 'a t -> 'b -> 'b 432 | val nil : unit -> 'a t 433 | val insert : 'a -> 'a t -> unit 434 | val cons : 'a -> 'a t -> 'a t 435 | val append : 'a t -> 'a t -> 'a t 436 | val try_again : unit -> 'a 437 | val warn : ('a, unit, string, 'b) format4 -> 'a 438 | val fail_with : Proc.status -> 'a 439 | type error_handler = [`Warning of string | `Exception of exn] -> unit 440 | val current_error_handler : error_handler ref 441 | val ignore_errors : error_handler 442 | val warn_on_errors : error_handler 443 | val die_on_errors : error_handler 444 | val die_silently_on_errors : error_handler 445 | val coshtream_of : ?procref:Channel.procref -> ('a t -> 'b) -> 'a co_t 446 | val conil : unit -> 'a co_t 447 | val conext : 'a co_t -> 'a -> unit 448 | val coclose : 'a co_t -> unit 449 | val annihilate : 'a t -> 'a co_t -> unit 450 | val from_low : ?close:(unit -> unit) -> (int -> 'a) -> 'a t 451 | val claim : 'a t -> 'a t 452 | val set_reader : 'a t -> (in_channel -> 'a) -> unit 453 | val hint_reader : 'a t -> Reader.t -> unit 454 | type protector = Util.protector 455 | val add_protection : protector -> 'a t -> unit 456 | val add_cleanup : (unit -> unit) -> 'a t -> unit 457 | end 458 | -------------------------------------------------------------------------------- /lib/signal.ml: -------------------------------------------------------------------------------- 1 | open Util 2 | 3 | exception Signal of int 4 | 5 | let signal_protect which ?(exn = Signal which) thunk = 6 | let old = Sys.signal which (Sys.Signal_handle (fun _ -> raise exn)) in 7 | unwind_protect thunk (fun _ -> ignore @@ Sys.signal which old) 8 | -------------------------------------------------------------------------------- /lib/signal.mli: -------------------------------------------------------------------------------- 1 | (** 2 | * Treat UNIX signals as OCaml exceptions. 3 | *) 4 | 5 | (** Raised by {!signal_protect} when a signal is delivered. *) 6 | exception Signal of int 7 | 8 | (** Call a thunk while delivering signals as exceptions. 9 | * [Signal.signal_protect n ~exn thunk] calls [thunk], handling 10 | * signal [n] by throwing exception [exn] instead. If [?exn] isn't 11 | * given, it default to [Signal n]. *) 12 | val signal_protect : int -> ?exn:exn -> (unit -> 'a) -> 'a 13 | 14 | -------------------------------------------------------------------------------- /lib/stringShtream.ml: -------------------------------------------------------------------------------- 1 | open Util 2 | 3 | module StringElem = struct 4 | type 'a elem = string 5 | type initial = unit 6 | let reader () = input_line 7 | let string_of () = id 8 | let of_string () = id 9 | end 10 | 11 | include AnyShtream.Make(StringElem) 12 | -------------------------------------------------------------------------------- /lib/stringShtream.mli: -------------------------------------------------------------------------------- 1 | (** Shtreams of strings. 2 | * This module is the result of applying {!AnyShtream.Make} to the 3 | * module {!StringElem}. 4 | * Thus, shtreams handled by this module are compatible with the shtreams 5 | * of {!Shtream}, {!LineShtream}, and modules created by 6 | * {!AnyShtream.Make}, but this module provides additional functions 7 | * for reading and writing [string Stream.t]s. 8 | *) 9 | 10 | (** The parameter given to {!AnyShtream.Make} to build {!StringShtream}. *) 11 | module StringElem : AnyShtream.ELEM 12 | with type 'a elem = string 13 | and type initial = unit 14 | 15 | (** The real contents of {!StringShtream}. *) 16 | include AnyShtream.S with module Elem = StringElem 17 | -------------------------------------------------------------------------------- /lib/tst.ml: -------------------------------------------------------------------------------- 1 | (** Simple-minded testing script that treats every executable file in 2 | a directory as a test and interprets its exit code/output as the 3 | result of the test. *) 4 | 5 | open Util 6 | open UsrBin 7 | open Fitting 8 | 9 | type result = Pass | Fail | XPass | XFail | InOutput | Unresolved 10 | 11 | let get_exes () = 12 | Shtream.list_of % 13 | Shtream.map ((^) "./") % 14 | Shtream.filter (Test.test (`And `Execute `Reg)) 15 | $ Shtream.map Line.raw (ls ".") 16 | 17 | let result_of_exit code = 18 | match code with 19 | 0 -> Pass 20 | | 1 -> Fail 21 | | 2 -> XPass 22 | | 3 -> XFail 23 | | 4 -> InOutput 24 | | _ -> Unresolved 25 | 26 | let exit_of_result res = 27 | match res with 28 | Pass -> 0 29 | | Fail -> 1 30 | | XPass -> 2 31 | | XFail -> 3 32 | | InOutput -> 4 33 | | Unresolved -> 5 34 | 35 | let snarf_channel c = 36 | let b = Buffer.create 80 in 37 | let rec loop () = 38 | try 39 | Buffer.add_string b (input_line c); 40 | Buffer.add_char b '\n'; 41 | loop () 42 | with End_of_file -> 43 | let s = Buffer.contents b in 44 | close_in c; s 45 | in loop () 46 | 47 | let run_test prog = 48 | let proc = ref None in 49 | let outc = run_in ~procref:proc (process ~path:false prog []) in 50 | let output = snarf_channel outc in 51 | (prog, 52 | (maybe !proc 53 | {| Unresolved |} 54 | (fun p -> 55 | match Proc.wait p with 56 | Unix.WEXITED n -> result_of_exit n 57 | | _ -> Unresolved)), output) 58 | 59 | (* 60 | (* Toploop is messing with me, and this code appears to be dead 61 | anyway. *) 62 | let is_compileable file = 63 | Toploop.use_file 64 | (Format.make_formatter (fun _ _ _ -> ()) ignore) 65 | file 66 | 67 | let test_compiles file = 68 | exit (exit_of_result $ 69 | if is_compileable file 70 | then Pass 71 | else Fail) 72 | *) 73 | 74 | let run_tests dir = 75 | let oldir = Unix.getcwd () in 76 | Unix.chdir dir; 77 | List.map run_test (get_exes ()) 78 | BEFORE 79 | Unix.chdir oldir 80 | 81 | (*************************************) 82 | open Arg 83 | 84 | if not !Sys.interactive then 85 | let dir = ref "." in 86 | let speclist = align 87 | (* key spec doc *) 88 | [ 89 | ] in 90 | parse speclist (fun x -> dir := x) (Sys.argv.(0) ^ " [dir]") 91 | -------------------------------------------------------------------------------- /lib/usrBin.ml: -------------------------------------------------------------------------------- 1 | open Util 2 | open Fitting 3 | 4 | let cat s = LineShtream.output s 5 | 6 | let cut selector = trans @@ Shtream.map (Line.select selector) 7 | 8 | let set_stat ?dir = 9 | Line.set_source (`Directory (maybe dir (fun _ -> ".") id)) % 10 | Adaptor.Stat.splitter ?dir 11 | 12 | let stat filename = 13 | set_stat ~dir:(Filename.dirname filename) 14 | (Line.line (Filename.basename filename)) 15 | 16 | let from_directory name = 17 | caml (fun _ -> 18 | let dir = Channel.opendir name in 19 | from_shtream @@ 20 | Shtream.from_low 21 | ~close:(fun _ -> Channel.closedir dir) 22 | (fun _ -> 23 | try Line.set_source (`Directory name) 24 | (Line.line (Channel.readdir dir)) with 25 | | End_of_file -> raise Shtream.Failure) 26 | ) 27 | 28 | let ls dir = 29 | from_directory dir -| Adaptor.Stat.fitting ~dir () 30 | 31 | let ps () = 32 | from_null -| program "ps" ["auxww"] -| Adaptor.Ps.fitting () 33 | 34 | 35 | let isatty fd = 36 | try ignore (Unix.tcgetattr fd); true with 37 | | Unix.Unix_error _ -> false 38 | 39 | module Test = struct 40 | let stat2 f1 f2 = (stat f1,stat f2) 41 | 42 | let z = (=) "" 43 | let n = (<>) "" 44 | 45 | let ef f1 f2 = 46 | try 47 | let (st1,st2) = stat2 f1 f2 in 48 | let (dev,ino) = Line.Stat.dev,Line.Stat.inode in 49 | (dev st1) = (dev st2) && (ino st1) = (ino st2) 50 | with _ -> false 51 | 52 | let nt f1 f2 = 53 | try 54 | let (st1,st2) = stat2 f1 f2 in 55 | Line.Stat.mtime st1 > Line.Stat.mtime st2 56 | with _ -> false 57 | 58 | let ot f1 f2 = 59 | try 60 | let (st1,st2) = stat2 f1 f2 in 61 | Line.Stat.mtime st1 < Line.Stat.mtime st2 62 | with _ -> false 63 | 64 | 65 | let file_pred pred f = try pred (stat f) with _ -> false 66 | let file_kind k = file_pred (((=) k) % Line.Stat.kind) 67 | 68 | let b = file_kind Unix.S_BLK 69 | let c = file_kind Unix.S_CHR 70 | let d = file_kind Unix.S_DIR 71 | let f = file_kind Unix.S_REG 72 | let h = file_kind Unix.S_LNK (* broken; use lstat *) 73 | let p = file_kind Unix.S_FIFO 74 | 75 | let e = file_pred (const true) 76 | let g = file_pred Line.Stat.Mode.sgid 77 | let k = file_pred Line.Stat.Mode.sticky 78 | let s = file_pred ((<) 0 % Line.Stat.size) 79 | let u = file_pred Line.Stat.Mode.suid 80 | 81 | let r f = try Unix.access f [Unix.R_OK];true with _ -> false 82 | let w f = try Unix.access f [Unix.W_OK];true with _ -> false 83 | let x f = try Unix.access f [Unix.X_OK];true with _ -> false 84 | 85 | let t d = isatty (Channel.descr_of_fd d) 86 | 87 | let tfile f = 88 | r f && let c = Channel.open_file_in f in 89 | unwind_protect 90 | (fun _ -> isatty (Unix.descr_of_in_channel c)) 91 | (fun _ -> Channel.close_in c) 92 | 93 | (* problematic: 94 | * -S (capitals in general) *) 95 | 96 | let rec test spec = 97 | match spec with 98 | `Exists -> e 99 | | `Char -> c 100 | | `Dir -> d 101 | | `Reg -> f 102 | | `Link -> h 103 | | `Pipe -> p 104 | | `Sgid -> s 105 | | `Sticky -> k 106 | | `NonEmpty -> s 107 | | `Suid -> u 108 | | `Tty -> tfile 109 | | `Read -> r 110 | | `Write -> w 111 | | `Execute -> x 112 | | `Newer f -> nt f 113 | | `Older f -> ot f 114 | | `Equal f -> ef f 115 | | `And (e1, e2) -> fun x -> (test e1 x) && (test e2 x) 116 | | `Or (e1, e2) -> fun x -> (test e1 x) || (test e2 x) 117 | end 118 | 119 | let echo msg = 120 | trans (fun _ -> Shtream.of_list [ Line.line msg ]) 121 | 122 | let cd = Unix.chdir 123 | let pwd = Unix.getcwd 124 | let sleep = Unix.sleep 125 | let mkdir = flip Unix.mkdir 0o777 126 | 127 | let mkpath = 128 | let rex = Pcre.regexp "/" in 129 | let mkdir name = 130 | try mkdir name with 131 | | Unix.Unix_error (Unix.EEXIST, _, _) -> () in 132 | fun path -> 133 | match Pcre.split ~rex path with 134 | | [] -> () 135 | | lst -> 136 | let each rest next = 137 | match rest, next with 138 | | "", "" -> "/" 139 | | "", _ -> mkdir next; next 140 | | _, _ -> let dir = rest^"/"^next in 141 | mkdir dir; dir in 142 | ignore @@ List.fold_left each "" lst 143 | 144 | let backquote = 145 | String.concat " " % 146 | LineShtream.string_list_of % 147 | LineShtream.of_command 148 | 149 | let lift_to_line2 f x y = f (Line.show x) (Line.show y) 150 | 151 | let sort ?(compare = lift_to_line2 String.compare) () = 152 | trans @@ Shtream.of_list % (List.fast_sort compare) % Shtream.list_of 153 | 154 | let head n = trans 155 | (fun s -> 156 | Shtream.from @@ fun i -> 157 | if i < n 158 | then Shtream.next' s 159 | else None) 160 | 161 | let head_while pred = trans 162 | (fun shtr -> 163 | let each _ = 164 | match Shtream.peek shtr with 165 | | Some v when pred v -> 166 | Shtream.next' shtr 167 | | _ -> None 168 | in Shtream.from each) 169 | 170 | let behead_while pred = 171 | trans 172 | (fun s -> 173 | while maybe (Shtream.peek s) (fun _ -> false) pred do 174 | Shtream.junk s 175 | done; s) 176 | 177 | let behead n = 178 | let count = ref 0 in 179 | behead_while 180 | (fun s -> 181 | let it = !count < n in 182 | count := !count + 1; 183 | it) 184 | 185 | let uniq ?(equal = lift_to_line2 (=)) () = 186 | trans @@ fun shtr -> 187 | let memory = ref None in 188 | let pred line = 189 | match !memory with 190 | | Some last when equal last line -> 191 | false 192 | | _ -> 193 | memory := Some line; true in 194 | Shtream.filter pred shtr 195 | 196 | let renumber from = 197 | trans 198 | (let count = ref from in 199 | Shtream.map (fun line -> 200 | let it = Line.set_seq !count line in 201 | count := !count + 1; 202 | it)) 203 | -------------------------------------------------------------------------------- /lib/usrBin.mli: -------------------------------------------------------------------------------- 1 | (** 2 | * High-level user utilities. 3 | *) 4 | 5 | (** {1 Fitting Commands} *) 6 | 7 | val ls : string -> ('a -> Line.t) Fitting.t 8 | (** List a directory, with file metadata. Given the name of a 9 | * directory, produces a fitting which outputs filenames with 10 | * {!Line.Stat} present. *) 11 | 12 | val from_directory : string -> ('a -> Line.t) Fitting.t 13 | (** Get the filenames in a directory. Doesn't provide metadata. *) 14 | 15 | val ps : unit -> ('a -> Line.t) Fitting.t 16 | (** Get a information about currently running processes. 17 | * Returns a fitting which outputs {b ps}(1) output with process metadata 18 | * in the {!Line.Ps} structure. *) 19 | 20 | val cut : (Line.t -> string) -> (Line.t -> Line.t) Fitting.t 21 | (** Select a particular field for each line passing through the fitting. 22 | * Given a function to show lines, sets {!Line.show} for each line in the 23 | * input. *) 24 | 25 | val head : int -> ('a -> 'a) Fitting.t 26 | (** [UsrBin.head n] is a fitting that only produces the first [n] 27 | * elements of its input. It leaves the rest for subsequent readers. *) 28 | 29 | val head_while : ('a -> bool) -> ('a -> 'a) Fitting.t 30 | (** A fitting that passes through elements satisfying a 31 | * predicate until encountering one that doesn't. 32 | * Leaves the remaining elements behind. *) 33 | 34 | val behead : int -> ('a -> 'a) Fitting.t 35 | (** [UsrBin.behead n] is a fitting that drops the first [n] lines of 36 | * its input. *) 37 | 38 | val behead_while : ('a -> bool) -> ('a -> 'a) Fitting.t 39 | (** A fitting that deletes lines satisfying a predicate until reaching 40 | * one that doesn't. *) 41 | 42 | val echo : string -> ('a -> Line.t) Fitting.t 43 | (** A fitting to print a string. *) 44 | 45 | val renumber : int -> (Line.t -> Line.t) Fitting.t 46 | (** Update the sequence numbers in the lines passing through the pipeline 47 | * to reflect the current sequence. The optional argument [?from] 48 | * (default [0]) specifies the number for the first element. *) 49 | 50 | val sort : ?compare:(Line.t -> Line.t -> int) -> unit -> (Line.t -> Line.t) Fitting.t 51 | (** Sort the lines coming into the fitting. Since {!sort} must eagerly 52 | * consume its in order to sort it, attempts to sort infinite shtreams 53 | * will require patience. *) 54 | 55 | val uniq : ?equal:(Line.t -> Line.t -> bool) -> unit -> (Line.t -> Line.t) Fitting.t 56 | (** Remove (adjacent) duplicate lines from the fitting's input. When 57 | * several lines are equal according the the predicate [?equal] 58 | * (default compares {!Line.show}), discards all but the first. 59 | *) 60 | 61 | (** {1 File Commands} *) 62 | 63 | val isatty : Channel.descr -> bool 64 | (** Is the given file descriptor a tty? *) 65 | 66 | val set_stat : ?dir:string -> Line.t -> Line.t 67 | (** Add file metadata to a {!line}. Uses the filename 68 | * in {!Line.raw} *) 69 | 70 | val stat : string -> Line.t 71 | (** Get file metadata for one file. 72 | * Creates a {!line} with {!Line.Stat} present. *) 73 | 74 | (** Functions similar to the UNIX {b test}(1) command. *) 75 | module Test : sig 76 | val z : string -> bool 77 | (** [Test.z str] is true if str has length 0, false otherwise. *) 78 | val n : string -> bool 79 | (** [Test.n str] is false if str has length 0, true otherwise. *) 80 | 81 | val ef : string -> string -> bool 82 | (** [Test.ef f1 f2] is true if files [f1] and [f2] are the same. *) 83 | val nt : string -> string -> bool 84 | (** [Test.nt f1 f2] is true if file [f1] is newer than [f2]. *) 85 | val ot : string -> string -> bool 86 | (** [Test.ot f1 f2] is true if file [f1] is older than [f2]. *) 87 | 88 | val b : string -> bool 89 | (** [Test.b file] is true if [file] exists and is block special. *) 90 | val c : string -> bool 91 | (** [Test.c file] is true if [file] exists and is character special. *) 92 | val d : string -> bool 93 | (** [Test.d file] is true if [file] exists and is a directory. *) 94 | val f : string -> bool 95 | (** [Test.f file] is true if [file] exists and is a regular file. *) 96 | val h : string -> bool 97 | (** [Test.h file] is true if [file] exists and is a symbolic link. *) 98 | val p : string -> bool 99 | (** [Test.p file] is true if [file] exists and is a named pipe. *) 100 | 101 | val e : string -> bool 102 | (** [Test.e file] is true if [file] exists. *) 103 | val g : string -> bool 104 | (** [Test.g file] is true if [file] exists and is set-group-ID. *) 105 | val k : string -> bool 106 | (** [Test.k file] is true if [file] exists and has its sticky bit 107 | set. *) 108 | val s : string -> bool 109 | (** [Test.s file] is true if [file] exists and is non-empty. *) 110 | val u : string -> bool 111 | (** [Test.u file] is true if [file] exists and is set-user-ID. *) 112 | val t : int -> bool 113 | (** [Test.u n] is true if [n] is a tty file descriptor. *) 114 | val tfile : string -> bool 115 | (** [Test.u file] is true if [file] is readable and is a tty. *) 116 | 117 | val r : string -> bool 118 | (** [Test.r file] is true if [file] exists and read permission is 119 | granted. *) 120 | val w : string -> bool 121 | (** [Test.w file] is true if [file] exists and write permission is 122 | granted. *) 123 | val x : string -> bool 124 | (** [Test.x file] is true if [file] exists and execute permission is 125 | granted. *) 126 | 127 | val test : 128 | ([< 129 | | `And of 'a * 'a 130 | | `Char 131 | | `Dir 132 | | `Equal of string 133 | | `Execute 134 | | `Exists 135 | | `Link 136 | | `Newer of string 137 | | `NonEmpty 138 | | `Older of string 139 | | `Or of 'a * 'a 140 | | `Pipe 141 | | `Read 142 | | `Reg 143 | | `Sgid 144 | | `Sticky 145 | | `Suid 146 | | `Tty 147 | | `Write 148 | ] as 'a) -> string -> bool 149 | (** Evaluate a more elaborate {!Test} expression. 150 | For instance, one might write 151 | [Test.test `And (`Read,`NonEmpty) file] to test whether 152 | [file] is both readable and non-empty. *) 153 | end 154 | 155 | (** {1 Other Commands} *) 156 | 157 | val backquote : string -> string 158 | (** Run a command and return its output. *) 159 | 160 | val cd : string -> unit 161 | (** Change the current working directory. *) 162 | 163 | val mkdir : string -> unit 164 | (** Create a directory. *) 165 | 166 | val mkpath : string -> unit 167 | (** Create a directory path, succeeding even if some components 168 | * exist. This is like {b mkdir}(1) with the {i -p} option. *) 169 | 170 | val pwd : unit -> string 171 | (** Find out the current working directory. *) 172 | 173 | val sleep : int -> unit 174 | (** Sleep for the given number of seconds. *) 175 | -------------------------------------------------------------------------------- /lib/util.ml: -------------------------------------------------------------------------------- 1 | (** Miscellaneous utility types and values. *) 2 | 3 | (** Indicates a bug in the library. This exception is raised in 4 | cases that violate library or language invariants. *) 5 | exception Bug 6 | 7 | (** The identity function *) 8 | let id x = x 9 | (** The {i K} combinator *) 10 | let const x y = x 11 | (** Function composition *) 12 | let (%) f g x = f (g x) 13 | (** Flip the arguments of a function *) 14 | let flip f x y = f y x 15 | 16 | (** Anonymous sum types *) 17 | type ('a, 'b) either = 18 | | Left of 'a 19 | | Right of 'b 20 | 21 | (** Projection from the anonymous sum type {!either} *) 22 | let either e l r = match e with 23 | | Left x -> l x 24 | | Right x -> r x 25 | 26 | (** Projection from [option] *) 27 | let maybe o n s = match o with 28 | | None -> n () 29 | | Some x -> s x 30 | 31 | (** Application inside [option] *) 32 | let oapply f o = match o with 33 | | None -> None 34 | | Some x -> Some (f x) 35 | 36 | (** Map exceptions to [None] *) 37 | let option_of_exn thunk = 38 | try Some (thunk ()) with _ -> None 39 | 40 | (** Call a thunk and then run cleanup code. [Util.unwind_protect thunk 41 | after] calls [thunk]. If [thunk] returns a value, it calls [after] and 42 | then returns the value. If [thunk] raises, it calls [after] and then 43 | re-raises. *) 44 | let unwind_protect thunk after = 45 | let result = try thunk () 46 | with e -> after (); raise e in 47 | after (); 48 | result 49 | 50 | (** Loop until a thunk returns [Some v]. [Util.while_none cond body] 51 | calls [cond]. If [cond] returns [Some v] then it returns [v]; if 52 | [cond] returns [None], it calls [body] and then tries iterates. *) 53 | let rec while_none cond body = 54 | match cond () with 55 | | Some r -> r 56 | | None -> body (); while_none cond body 57 | 58 | (** Find an element in a list. Like [List.find'], but returns an 59 | * [option] rather than raising. *) 60 | let rec find' p lst = match lst with 61 | | [] -> None 62 | | x :: _ when p x -> Some x 63 | | _ :: xs -> find' p xs 64 | 65 | (** Record type for universally quantified {i around} advice. *) 66 | type protector = { protector: 'a . (unit -> 'a) -> 'a; } 67 | -------------------------------------------------------------------------------- /lib/version.ml: -------------------------------------------------------------------------------- 1 | let version = "%%VERSION%%" 2 | let version_name = "%%CODENAME%%" 3 | -------------------------------------------------------------------------------- /lib/version.mli: -------------------------------------------------------------------------------- 1 | (** Information about this version of Shcaml. *) 2 | 3 | val version : string 4 | (** The current version number. *) 5 | val version_name : string 6 | (** The current version name. *) 7 | -------------------------------------------------------------------------------- /lib/weakPlus.ml: -------------------------------------------------------------------------------- 1 | (* 2 | * This module implements weak references and weak hash tables. The 3 | * functor Make is used to construct a new weak hash table structure. 4 | *) 5 | open Util 6 | 7 | module type WEAKPLUS = sig 8 | type 'a t 9 | type key 10 | 11 | val create : int -> 'a t 12 | val resize : ?size:int -> 'a t -> unit 13 | val add : 'a t -> key -> 'a -> unit 14 | val remove : 'a t -> key -> unit 15 | val find' : 'a t -> key -> 'a option 16 | val find : 'a t -> key -> 'a 17 | val mem : 'a t -> key -> bool 18 | val count : 'a t -> int 19 | val iter : (key -> 'a -> unit) -> 'a t -> unit 20 | end 21 | 22 | module Make(H : Hashtbl.HashedType) = struct 23 | type key = H.t 24 | 25 | (* 26 | * A weak hash table stores keys in an array of weak buckets. 27 | * We hash into the outer array, and then search the bucket to see if 28 | * the key has been retained. Associated values are found in 29 | * an array of arrays of the same shape. 30 | * 31 | * We use an operation counter to determine when it might be a good 32 | * idea to resize the array. 33 | *) 34 | type 'a t = { 35 | mutable keys : key Weak.t array; 36 | mutable values : 'a option array array; 37 | mutable ops : int; 38 | } 39 | 40 | let minsize = 10 41 | 42 | (* 43 | * Some helper functions 44 | *) 45 | 46 | let hash h k = (H.hash k) mod (Array.length h.keys) 47 | 48 | (* To find/set the buckets in which a particular key falls. *) 49 | let get_buckets h k = 50 | let index = hash h k in 51 | (h.keys.(index), h.values.(index)) 52 | 53 | let put_buckets h k kb vb = 54 | let index = hash h k in 55 | h.keys.(index) <- kb; 56 | h.values.(index) <- vb 57 | 58 | (* To find the index of a key within a bucket. *) 59 | let get_index bucket k = 60 | let limit = Weak.length bucket in 61 | let rec loop i = 62 | if i < limit then 63 | match Weak.get bucket i with 64 | | Some k' when H.equal k k' -> Some i 65 | | _ -> loop (i + 1) 66 | else None 67 | in loop 0 68 | 69 | (* 70 | * To add an association, we find the appropriate bucket and check 71 | * if the binding already exists -- if so, we replace it. Otherwise, 72 | * we search for an open slot to place it in. If none exists, we double 73 | * the bucket size, copy the contents, and insert into the new bucket. 74 | *) 75 | let real_add h k v = 76 | let update kb vb i = 77 | Weak.set kb i (Some k); 78 | vb.(i) <- Some v in 79 | let (key_bucket, val_bucket) = get_buckets h k in 80 | match get_index key_bucket k with 81 | | Some i -> val_bucket.(i) <- Some v 82 | | _ -> 83 | let limit = Weak.length key_bucket in 84 | let rec loop i = 85 | if i < limit then 86 | match Weak.get key_bucket i with 87 | | Some _ -> loop (i + 1) 88 | | _ -> update key_bucket val_bucket i 89 | else ( 90 | let new_kb = Weak.create (2 * limit + 1) in 91 | let new_vb = Array.make (2 * limit + 1) None in 92 | for i = 0 to limit - 1 do 93 | match Weak.get key_bucket i with 94 | | Some _ as sk -> Weak.set new_kb i sk; 95 | new_vb.(i) <- val_bucket.(i) 96 | | _ -> () 97 | done; 98 | update new_kb new_vb limit; 99 | put_buckets h k new_kb new_vb) in 100 | loop 0 101 | 102 | (* Public methods *) 103 | 104 | let create n = 105 | let n = max n minsize in { 106 | ops = 0; 107 | keys = Array.make n (Weak.create 0); 108 | values = Array.make n (Array.make 0 None); 109 | } 110 | 111 | let count h = 112 | let result = ref 0 in 113 | for i = 0 to Array.length h.keys - 1 do 114 | let bucket = h.keys.(i) in 115 | for j = 0 to Weak.length bucket - 1 do 116 | match Weak.get bucket j with 117 | | Some _ -> result := !result + 1 118 | | _ -> () 119 | done 120 | done; 121 | !result 122 | 123 | let iter f h = 124 | for i = 0 to Array.length h.keys - 1 do 125 | let kb = h.keys.(i) in 126 | let vb = h.values.(i) in 127 | for j = 0 to Weak.length kb - 1 do 128 | match Weak.get kb j, vb.(j) with 129 | | Some k, Some v -> f k v 130 | | _ -> () 131 | done 132 | done 133 | 134 | let resize ?size h = 135 | let size = maybe size (fun () -> count h) id in 136 | let new_h = create size in 137 | iter (real_add new_h) h; 138 | h.keys <- new_h.keys; 139 | h.values <- new_h.values; 140 | h.ops <- new_h.ops 141 | 142 | let maybe_resize_helper h = 143 | let used = count h in 144 | let size = Array.length h.keys in 145 | if 4 * used < size || 4 * size < used 146 | then resize ~size:used h 147 | 148 | let tick_helper h = 149 | if h.ops >= 4 * Array.length h.keys then 150 | maybe_resize_helper h 151 | else 152 | h.ops <- h.ops + 1 153 | 154 | let add h k v = 155 | real_add h k v; 156 | tick_helper h 157 | 158 | let find' h k = 159 | let (key_bucket, val_bucket) = get_buckets h k in 160 | match get_index key_bucket k with 161 | | Some i -> val_bucket.(i) 162 | | None -> None 163 | 164 | let find h k = match find' h k with 165 | | Some v -> v 166 | | _ -> raise Not_found 167 | 168 | let mem h k = find' h k <> None 169 | 170 | let remove h k = 171 | let (key_bucket, val_bucket) = get_buckets h k in 172 | match get_index key_bucket k with 173 | | Some i -> Weak.set key_bucket i None; 174 | val_bucket.(i) <- None; 175 | tick_helper h 176 | | _ -> () 177 | end 178 | 179 | (** Weak reference cells. *) 180 | module Ref : sig 181 | type 'a t 182 | (** A weak cell containing an ['a] *) 183 | val create : 'a -> 'a t 184 | (** Create a new weak cell containing a value. *) 185 | val get : 'a t -> 'a option 186 | (** Get the value in a weak cell, or [None] if it's been freed. *) 187 | val set : 'a t -> 'a -> unit 188 | (** Set the value of a weak cell. *) 189 | val clear : 'a t -> unit 190 | (** Clear the value from a weak cell. *) 191 | end = struct 192 | type 'a t = 'a Weak.t 193 | let get w = Weak.get w 0 194 | let set w v = Weak.set w 0 (Some v) 195 | let clear w = Weak.set w 0 None 196 | let create v = 197 | let w = Weak.create 1 in 198 | set w v; 199 | w 200 | end 201 | -------------------------------------------------------------------------------- /lib/weakPlus.mli: -------------------------------------------------------------------------------- 1 | (** Hash tables with weak keys and strong values. *) 2 | 3 | (** The output signature of the functor {!WeakPlus.Make}. *) 4 | module type WEAKPLUS = sig 5 | type 'a t 6 | (** The type of weak-key hash table with values of type ['a] *) 7 | type key 8 | (** The key type of the hash table *) 9 | 10 | val create : int -> 'a t 11 | (** Create a new, empty hash table with the given initial size. 12 | The table grows as needed. *) 13 | val resize : ?size:int -> 'a t -> unit 14 | (** Resize a hash table. If no [?size] is given, guesses based 15 | on the current size of the table. *) 16 | 17 | val add : 'a t -> key -> 'a -> unit 18 | (** Bind a key to a value, replacing any previous value. *) 19 | val remove : 'a t -> key -> unit 20 | (** Remove a key-value association. *) 21 | 22 | val find' : 'a t -> key -> 'a option 23 | (** Look up a value by a key, returning [None] if not found. *) 24 | val find : 'a t -> key -> 'a 25 | (** Look up a value by a key, raising [Not_found] if not found. *) 26 | val mem : 'a t -> key -> bool 27 | (** Is a key present in the table? *) 28 | val count : 'a t -> int 29 | (** How many keys are present in the table? *) 30 | val iter : (key -> 'a -> unit) -> 'a t -> unit 31 | (** Apply a function to all bindings in a table. *) 32 | end 33 | 34 | (** Build an implementation of the weak-key hashtable structure. 35 | Takes the same argument structure as [Hashtbl.Make]. *) 36 | module Make(H : Hashtbl.HashedType) : WEAKPLUS with type key = H.t 37 | -------------------------------------------------------------------------------- /myocamlbuild.ml: -------------------------------------------------------------------------------- 1 | open Ocamlbuild_plugin 2 | 3 | let generate_INDEX env build = 4 | Cmd (Sh "sed -nf doc/make-index.sed doc/tutorial.ml > doc/INDEX") 5 | 6 | let build_shcaml_doc env build = 7 | let generate_html = 8 | Ocamlbuild_pack.Ocaml_tools.document_ocaml_project 9 | ~ocamldoc:Ocamlbuild_pack.Ocaml_tools.ocamldoc_l_dir 10 | "doc/api.odocl" 11 | "doc/api.docdir/index.html" 12 | "doc/api.docdir" 13 | env build 14 | in 15 | let postprocess_html = Cmd (A "doc/postprocess.byte") in 16 | Seq [generate_html; postprocess_html] 17 | 18 | 19 | let () = 20 | rule "shcaml ocamldoc" 21 | ~insert:(`top) 22 | ~prod:"doc/api.docdir/index.html" 23 | ~stamp:"doc/api.docdir/html.stamp" 24 | ~deps:["doc/api.odocl"; "doc/postprocess.byte"; "doc/INDEX"] 25 | build_shcaml_doc; 26 | 27 | rule "shcaml INDEX" 28 | ~insert:(`top) 29 | ~prod:"doc/INDEX" 30 | ~deps:["doc/make-index.sed"; "doc/tutorial.ml"] 31 | generate_INDEX 32 | 33 | let () = dispatch (fun hook -> 34 | begin match hook with 35 | | Before_options -> 36 | Options.ocaml_docflags := [ 37 | "-colorize-code"; 38 | "-charset"; "utf8"; 39 | "-stars"; 40 | "-t"; "Shcaml"; 41 | "-intro"; "doc/INDEX" 42 | ] 43 | | _ -> () 44 | end; 45 | Ocamlbuild_cppo.dispatcher hook 46 | ) 47 | -------------------------------------------------------------------------------- /opam: -------------------------------------------------------------------------------- 1 | opam-version: "1.2" 2 | authors: "Jesse A. Tov " 3 | maintainer: "Armael " 4 | homepage: "https://github.com/tov/shcaml" 5 | dev-repo: "git+https://github.com/tov/shcaml.git" 6 | bug-reports: "https://github.com/tov/shcaml/issues" 7 | doc: "https://tov.github.io/shcaml/doc" 8 | license: "MIT" 9 | available: [ ocaml-version >= "4.02.0" ] 10 | depends: [ "ocamlfind" {build} 11 | "ocamlbuild" {build} 12 | "topkg" {build & >= "0.9.0"} 13 | "cppo" {build} 14 | "pcre" 15 | "hmap" 16 | "stdcompat" 17 | ] 18 | depopts: [ "lwt" "base-unix" ] 19 | build: 20 | [ 21 | [ "ocaml" "pkg/pkg.ml" "build" 22 | "--dev-pkg" "%{pinned}%" 23 | "--with-lwt" "%{lwt+base-unix:installed}%" 24 | ] 25 | ] 26 | -------------------------------------------------------------------------------- /pkg/META: -------------------------------------------------------------------------------- 1 | name = "shcaml" 2 | version = "%%VERSION%%" 3 | description = "Shcaml is an OCaml library for UNIX shell programming" 4 | requires = "unix hmap pcre lwt.unix stdcompat" 5 | archive(byte) = "shcaml.cma" 6 | plugin(byte) = "shcaml.cma" 7 | archive(native) = "shcaml.cmxa" 8 | plugin(native) = "shcaml.cmxs" 9 | exists_if = "shcaml.cma" 10 | 11 | package "top" ( 12 | version = "%%VERSION%%" 13 | description = "Shcaml toplevel support" 14 | requires = "shcaml" 15 | archive(byte) = "shcaml_top.cma" 16 | plugin(byte) = "shcaml_top.cma" 17 | archive(native) = "shcaml_top.cmxa" 18 | plugin(native) = "shcaml_top.cmxs" 19 | exists_if = "shcaml_top.cma" 20 | ) 21 | -------------------------------------------------------------------------------- /pkg/pkg.ml: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env ocaml 2 | #use "topfind" 3 | #require "topkg" 4 | open Topkg 5 | 6 | let codename = "Shmaltz" 7 | (* shlock shadken shanda shaygets shayner shiksa 8 | shlemiel shlep shmendrick shmegegge 9 | shmutzik shnorrer shtik shtetl shtunk 10 | shvitz 11 | 12 | Used: 13 | 0.1.0 shmatta 14 | 0.1.1 shmooz 15 | 0.1.2 shlimazl 16 | 0.1.3 shmeer 17 | 0.2.0 shmaltz 18 | *) 19 | 20 | let lwt = Conf.with_pkg "lwt" 21 | 22 | let build_cmd c os files = 23 | OS.Cmd.run 24 | Cmd.( 25 | Pkg.build_cmd c os %% 26 | v "-plugin-tag" %% v "package(cppo_ocamlbuild)" %% 27 | Pkg.ocb_bool_tag c lwt "cppo_D(WITH_LWT)" %% 28 | Pkg.ocb_bool_tag c lwt "package(lwt.unix)" %% 29 | of_list files 30 | ) 31 | 32 | let build = Pkg.build ~cmd:build_cmd () 33 | let opams = [Pkg.opam_file ~lint_deps_excluding:(Some ["cppo"; "lambdasoup"; "lwt"]) "opam"] 34 | let distrib = 35 | let watermarks = ("CODENAME", `String codename) :: Pkg.watermarks in 36 | Pkg.distrib ~watermarks () 37 | 38 | let () = 39 | Pkg.describe ~opams ~build:(Pkg.build ~cmd:build_cmd ()) ~distrib "shcaml" @@ fun c -> 40 | Ok [ Pkg.mllib ~api:[] "lib/shcaml.mllib"; 41 | Pkg.lib ~exts:(Exts.exts [".cmi"; ".cmti"]) "lib/shcaml"; 42 | Pkg.mllib ~api:[] "lib/shcaml_top.mllib"; 43 | Pkg.lib "lib/shcaml_top_init.ml"; 44 | ] 45 | -------------------------------------------------------------------------------- /tests/basic_line_test.ml: -------------------------------------------------------------------------------- 1 | #directory "..";; 2 | #load "line.cmo";; 3 | 4 | let foo = Line.line "foo";; 5 | let bar = Line.raw foo;; 6 | let baz = Line.Ls.inode foo;; 7 | 8 | -------------------------------------------------------------------------------- /tests/basic_line_test_driver.ml: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env /home/alec/janest/shcaml/shtop 2 | 3 | #directory "..";; 4 | #shcaml;; 5 | 6 | 7 | (Tst.test_compiles "basic_line_test.ml") 8 | -------------------------------------------------------------------------------- /tests/csv.ml: -------------------------------------------------------------------------------- 1 | #! /usr/bin/env ocamlscript 2 | Ocaml.packs := [ "shcaml" ] 3 | -- 4 | 5 | (* Tests for lib/csv.ml *) 6 | 7 | open Shcaml 8 | open Util 9 | open Csv 10 | open Printf 11 | 12 | let raised_unexp = ref 0 13 | let didn't_raise = ref 0 14 | let didn't_match = ref 0 15 | let total_tests = ref 0 16 | let failed_tests = ref 0 17 | 18 | let content x = x.Reader.content 19 | 20 | let prerr_options options = 21 | eprintf "{ "; 22 | if options.field_sep <> default_options.field_sep then 23 | eprintf "field_sep = '%c'; " options.field_sep; 24 | if options.record_sep <> default_options.record_sep then 25 | eprintf "record_sep = '%c'; " options.record_sep; 26 | if options.trim_space <> default_options.trim_space then 27 | eprintf "trim_space = %b; " options.trim_space; 28 | if options.rec_backslash <> default_options.rec_backslash then 29 | eprintf "rec_backslash = %b; " options.rec_backslash; 30 | if options.rec_quotation <> default_options.rec_quotation then 31 | eprintf "rec_quotation = %b; " options.rec_quotation; 32 | if options.rec_double_double <> 33 | default_options.rec_double_double then 34 | eprintf "rec_double_double = %b; " 35 | options.rec_double_double; 36 | if options.rec_cr <> 37 | default_options.rec_cr then 38 | eprintf "rec_cr = %b; " 39 | options.rec_cr; 40 | if options.rec_escapes <> 41 | default_options.rec_escapes then 42 | eprintf "rec_escapes = %b; " 43 | options.rec_escapes; 44 | eprintf " }\n" 45 | 46 | let prerr_records recs = 47 | eprintf "[\n"; 48 | List.iter (fun record -> 49 | eprintf " [| "; 50 | Array.iter (eprintf "\"%s\"; " % String.escaped) record; 51 | eprintf "|]\n") recs; 52 | eprintf "]\n" 53 | 54 | let roundtrip good options recs = 55 | total_tests := !total_tests + 1; 56 | match try Some (Channel.with_out_string (fun outc -> 57 | List.iter (output_record ~options outc) recs)) 58 | with Failure _ -> None with 59 | | None when good options -> 60 | raised_unexp := !raised_unexp + 1; 61 | failed_tests := !failed_tests + 1; 62 | printf "Houston, we threw unexpectedly:\n "; 63 | prerr_options options; 64 | prerr_newline () 65 | | None -> eprintf "*" 66 | | Some (_, serialized) when not (good options) -> 67 | didn't_raise := !didn't_raise + 1; 68 | failed_tests := !failed_tests + 1; 69 | printf "Houston, we succeeded unexpectedly:\n "; 70 | prerr_options options; 71 | eprintf "<<<%s>>>\n" serialized; 72 | prerr_newline () 73 | | Some (_, serialized) -> 74 | let inc = Channel.open_string_in serialized in 75 | let get = splitter ~options % content % reader ~options in 76 | let rec loop acc = 77 | match try Some (get inc) with 78 | | End_of_file -> None 79 | | e -> 80 | eprintf "\nOops, bailing out\n"; 81 | prerr_options options; 82 | prerr_records recs; 83 | eprintf "<<<%s>>>\n" serialized; 84 | raise e 85 | with 86 | | Some record -> loop (record :: acc) 87 | | None -> List.rev acc in 88 | let back = loop [] in 89 | if back = recs then 90 | eprintf "." 91 | else begin 92 | didn't_match := !didn't_match + 1; 93 | failed_tests := !failed_tests + 1; 94 | eprintf "Houston, we have a problem:\n "; 95 | prerr_options options; 96 | prerr_records recs; 97 | eprintf "<<<%s>>>\n" serialized; 98 | prerr_records back; 99 | prerr_newline () 100 | end; 101 | close_in inc 102 | 103 | let concat_map = Shtream.concat_map 104 | 105 | let option_set = 106 | Shtream.list_of ^$ 107 | concat_map (fun o -> [ {o with field_sep = ','}; 108 | {o with field_sep = ' '}; 109 | {o with field_sep = 'v'}; 110 | {o with field_sep = '\t'}; ]) ^$ 111 | concat_map (fun o -> [ {o with record_sep = '\n'}; 112 | {o with record_sep = '\000'}; ]) ^$ 113 | concat_map (fun o -> [ {o with trim_space = true}; 114 | {o with trim_space = false}; ]) ^$ 115 | concat_map (fun o -> [ {o with rec_backslash = false}; 116 | {o with rec_backslash = true}; ]) ^$ 117 | concat_map (fun o -> [ {o with rec_quotation = true}; 118 | {o with rec_quotation = false}; ]) ^$ 119 | concat_map (fun o -> [ {o with rec_double_double = true}; 120 | {o with rec_double_double = false}; ]) ^$ 121 | concat_map (fun o -> [ {o with rec_cr = true}; 122 | {o with rec_cr = false}; ]) ^$ 123 | concat_map (fun o -> [ {o with rec_escapes = false}; 124 | {o with rec_escapes = true}; ]) ^$ 125 | Shtream.of_list [ default_options ] 126 | ;; 127 | 128 | let good options = if String.contains " \t\r\n" options.field_sep && 129 | options.trim_space then 130 | options.rec_quotation 131 | else true in 132 | flip List.iter option_set ^$ fun options -> 133 | roundtrip good options [ 134 | [| "a"; ""; "b" |]; 135 | [| "c"; "" |]; 136 | [| ""; "c" |]; 137 | [| ""; "" |]; 138 | ] 139 | ;; 140 | 141 | let good options = true in 142 | flip List.iter option_set ^$ fun options -> 143 | roundtrip good options [ 144 | [| "a" |]; 145 | [| "a"; "bc"; "de" |]; 146 | ] 147 | ;; 148 | 149 | let good options = if options.field_sep = ' ' then 150 | options.rec_backslash or 151 | options.rec_escapes or 152 | options.rec_quotation 153 | else true in 154 | flip List.iter option_set ^$ fun options -> 155 | roundtrip good options [ 156 | [| "a" |]; 157 | [| "a"; "b\\c"; "d e" |]; 158 | ] 159 | ;; 160 | 161 | let good options = if options.field_sep = ' ' || 162 | options.trim_space then 163 | options.rec_backslash or 164 | options.rec_escapes or 165 | options.rec_quotation 166 | else true in 167 | flip List.iter option_set ^$ fun options -> 168 | roundtrip good options [ 169 | [| "a" |]; 170 | [| "a"; "b\\c"; "d e" |]; 171 | [| " a"; "bc "; " " |]; 172 | [| " a"; "bc "; " "; " " |]; 173 | ] 174 | ;; 175 | 176 | let good options = options.rec_backslash or 177 | options.rec_escapes or 178 | options.rec_quotation in 179 | flip List.iter option_set ^$ fun options -> 180 | roundtrip good options [ 181 | [| "a"; "b\\c"; "d e" |]; 182 | [| " a\n"; "b,c "; " " |]; 183 | [| " va"; "bc "; " "; " \n \t " |]; 184 | [| " \006\\" |] 185 | ] 186 | ;; 187 | 188 | let good options = options.rec_backslash or 189 | options.rec_escapes or 190 | (options.rec_quotation && 191 | (options.rec_double_double or 192 | options.rec_backslash or 193 | options.rec_escapes)) in 194 | flip List.iter option_set ^$ fun options -> 195 | roundtrip good options [ 196 | [| "a"; "b\\c"; "d\000 e" |]; 197 | [| " a\n"; "b,c "; " " |]; 198 | [| " va"; "b\"c "; " "; " \n \t " |]; 199 | [| " \006"; "\\\""; "\"\"\\\"" |]; 200 | ] 201 | ;; 202 | 203 | prerr_newline (); 204 | prerr_newline (); 205 | eprintf "raised unexpectedly: %d\n" !raised_unexp; 206 | eprintf "didn't raise when expected: %d\n" !didn't_raise; 207 | eprintf "didn't match when expected: %d\n" !didn't_match; 208 | prerr_newline (); 209 | eprintf "failed tests: %d\n" !failed_tests; 210 | eprintf "total tests: %d\n" !total_tests; 211 | () 212 | -------------------------------------------------------------------------------- /tests/dup_protect.ml: -------------------------------------------------------------------------------- 1 | #! /usr/bin/env ocamlscript 2 | Ocaml.packs := [ "shcaml" ];; 3 | -- 4 | 5 | (* This tests the ability of shtreams to remember the fd environment in 6 | * which their generators are to be run. This should send a bunch of 7 | * meows to stdout, not stderr. *) 8 | 9 | open Shcaml 10 | open Channel.Dup 11 | open Fitting 12 | 13 | let f x = prerr_endline "meow"; Shtream.try_again () 14 | ;; 15 | let s = run_source begin 16 | from_file "/etc/passwd" -| 17 | sed f />/ [ 2 %>& 1 ] 18 | end in 19 | LineShtream.output s 20 | -------------------------------------------------------------------------------- /tests/fail: -------------------------------------------------------------------------------- 1 | #!/bin/sh 2 | 3 | echo "dummy fail" 4 | 5 | exit 1 -------------------------------------------------------------------------------- /tests/pass: -------------------------------------------------------------------------------- 1 | #!/bin/sh 2 | 3 | echo "dummy pass" 4 | 5 | exit 0 -------------------------------------------------------------------------------- /tests/sequencing.sh: -------------------------------------------------------------------------------- 1 | #!/bin/sh 2 | 3 | source `dirname $0`/test_lib.sh 4 | 5 | prepare run_in simple <> command "echo here" ^>> trans id 8 | end in try while true do 9 | print_endline (input_line c) 10 | done with 11 | | End_of_file -> () 12 | END 13 | 14 | run hello <> command "echo here" ^>> trans id 43 | end 44 | END 45 | 46 | run hello <$infile <<....EOF 17 | #use "topfind";; 18 | #camlp4o;; 19 | #require "shcaml";; 20 | ....EOF 21 | cat >>$infile 22 | } 23 | 24 | run () { 25 | subname="$*" 26 | ocaml $infile >$outfile 2>$errfile 27 | } 28 | 29 | check () { 30 | if ! diff - $1 >$difffile; then 31 | echo 32 | echo "$name:$subname ($2)" 33 | cat $difffile 34 | fi 35 | } 36 | 37 | check1 () { 38 | check $outfile stdout 39 | } 40 | 41 | check2 () { 42 | check $errfile stderr 43 | } 44 | 45 | finish () { 46 | rm -f $infile $outfile $errfile $difffile $fifo 47 | echo done. 48 | } 49 | --------------------------------------------------------------------------------