Permalink
Browse files

[contrib] merge: pull request #56 from git://github.com/winbomb/opalang

  • Loading branch information...
2 parents 6db2127 + 3a7319e commit 8b87a098deb4d33d036f65a8a1d95aa051358010 @BourgerieQuentin BourgerieQuentin committed May 29, 2012
Showing with 2,407 additions and 543 deletions.
  1. +2 −0 .gitignore
  2. +7 −0 CHANGELOG
  3. +5 −1 libbase/baseChar.ml
  4. +2 −1 libbase/baseChar.mli
  5. +6 −6 libbase/baseString.ml
  6. +1 −1 libbase/baseString.mli
  7. +29 −29 libbase/baseUtf8.ml
  8. +4 −1 libbase/baseUtf8.mli
  9. +5 −1 libbase/cactutf.mli
  10. +48 −0 libnet/imapClientCore.proto
  11. +7 −4 libqmlcompil/dbGen/dbGen_private.ml
  12. +78 −42 libqmlcompil/dbGen/schema_private.ml
  13. +63 −30 libqmlcompil/qmlAst.ml
  14. +11 −8 libqmlcompil/qmlDbGen.ml
  15. +5 −0 libqmlcompil/qmlTypesUtils.ml
  16. +4 −0 libqmlcompil/qmlTypesUtils.mli
  17. +5 −3 opa/opa_InsertRemote.ml
  18. +170 −109 opa/pass_MongoAccessGeneration.ml
  19. +35 −4 opabsl/jsbsl/bslSession.js
  20. +3 −3 opabsl/jsbsl/bslString.js
  21. +2 −1 opabsl/mlbsl/bslCactutf.ml
  22. +19 −14 opabsl/mlbsl/bslSession.ml
  23. +59 −28 opabsl/mlbsl/bslString.ml
  24. +1 −0 opacapi/opacapi.ml
  25. 0 opadoc/manual.omd/{ → en}/about.omd
  26. 0 opadoc/manual.omd/{ → en}/example.omd
  27. 0 opadoc/manual.omd/{ → en}/hello_bindings.omd
  28. +6 −7 opadoc/manual.omd/{ → en}/hello_chat.omd
  29. 0 opadoc/manual.omd/{ → en}/hello_database.omd
  30. 0 opadoc/manual.omd/{ → en}/hello_distribution.omd
  31. 0 opadoc/manual.omd/{ → en}/hello_recaptcha.omd
  32. 0 opadoc/manual.omd/{ → en}/hello_web_services.omd
  33. 0 opadoc/manual.omd/{ → en}/hello_web_services_client.omd
  34. 0 opadoc/manual.omd/{ → en}/hello_wiki.omd
  35. 0 opadoc/manual.omd/{ → en}/index
  36. 0 opadoc/manual.omd/{ → en}/install.omd
  37. 0 opadoc/manual.omd/{ → en}/missing
  38. 0 opadoc/manual.omd/{ → en}/ref_core_language.omd
  39. +145 −33 opadoc/manual.omd/{ → en}/ref_database.omd
  40. 0 opadoc/manual.omd/{ → en}/ref_execution.omd
  41. 0 opadoc/manual.omd/{ → en}/ref_filenames.omd
  42. 0 opadoc/manual.omd/{ → en}/ref_mongodb.omd
  43. 0 opadoc/manual.omd/{ → en}/ref_type_system.omd
  44. 0 opadoc/manual.omd/{ → en}/ref_web_language.omd
  45. 0 opadoc/manual.omd/{ → en}/tour.omd
  46. +2 −0 opadoc/manual.omd/langs
  47. +558 −0 opadoc/manual.omd/zh/hello_chat.omd
  48. +366 −0 opadoc/manual.omd/zh/hello_wiki.omd
  49. +5 −0 opadoc/manual.omd/zh/index
  50. +191 −0 opadoc/manual.omd/zh/install.omd
  51. +209 −0 opadoc/manual.omd/zh/tour.omd
  52. +5 −6 opadoc/manual.src/hello_chat/hello_chat.opa
  53. 0 opadoc/manual.src/hello_chat/resources/{css.css → chat.css}
  54. +1 −1 opadoc/manual.src/hello_web_services/hello_wiki_rest.opa
  55. +1 −1 opadoc/manual.src/hello_web_services/hello_wiki_rest_client.opa
  56. +5 −2 opadoc/manual.src/hello_wiki/hello_wiki.opa
  57. +28 −9 opadoc/manual.src/opa_binding_examples/opa_types/dbm.opa
  58. +5 −5 opadoc/refcard.omd
  59. +1 −0 opalang/classic_syntax/opa_lexer.trx
  60. +5 −0 opalang/classic_syntax/opa_parser.trx
  61. +48 −22 opalang/classic_syntax/parser_path.trx
  62. +2 −1 opalang/classic_syntax/trx.trx
  63. +1 −1 opalang/classic_syntax/xml.trx
  64. +6 −2 opalang/classic_syntax/xml_parser.trx
  65. +4 −4 opalang/js_syntax/opa_parser.trx
  66. +1 −1 opalang/js_syntax/trx.trx
  67. +20 −55 qmlpasses/pass_DbAccessorsGeneration.ml
  68. +12 −2 qmlpasses/pass_ExplicitInstantiation.ml
  69. +33 −4 qmlpasses/pass_ExplicitInstantiation.mli
  70. +24 −16 stdlib/apis/mongo/bson.opa
  71. +50 −37 stdlib/core/cache/cache.opa
  72. +3 −1 stdlib/core/cactutf.opa
  73. +1 −1 stdlib/core/date/duration.opa
  74. +2 −1 stdlib/core/funaction/funaction.opa
  75. +1 −0 stdlib/core/map/map.opa
  76. +2 −1 stdlib/core/string.opa
  77. +24 −20 stdlib/core/web/resource/resource_private.opa
  78. +23 −5 stdlib/core/web/server/server_private.opa
  79. +22 −4 stdlib/core/xhtml/xhtml.opa
  80. +17 −8 stdlib/database/mongo/db.opa
  81. +1 −1 stdlib/tests/ok_ko.opa
  82. +6 −6 stdlib/web/mail/mime.opa
View
@@ -17,3 +17,5 @@ access.log
error.log
*.native
repos/
+
+ocamlbase.top
View
@@ -6,6 +6,10 @@ New supported platform:
New features:
+ * Doc: 4 first chapters translated in Chinese.
+ Thanks to Li Wenbo <li.wenbo@whu.edu.cn> for this major contribution!
+ Online preview: http://cn.doc.opalang.org
+
* Syntax:
- Possibility to use underscore inside numbers
- In js-like syntax, block braces of inserts can be used as delimiting a anonymous block function.
@@ -73,6 +77,8 @@ Improvements:
* Better check of wrong cyclic type definition
+ * Faster parsing of Mime Miltipart message
+
Bug fixes:
* UriParser
@@ -98,6 +104,7 @@ Updated APIs:
* Cache
- removed deprecated Negociator API (misspelled)
+ - added reset function to reset cache entirely
* Mime
- Mime.get_text now takes an additional decoding function
View
@@ -1,5 +1,5 @@
(*
- Copyright © 2011 MLstate
+ Copyright © 2011, 2012 MLstate
This file is part of OPA.
@@ -81,3 +81,7 @@ let hexa_value c =
else if c >= 'a' && c <= 'f' then 87 (* int_of_char 'a' - 10 *)
else assert false
)
+
+let cache fun_charset =
+ let table = Array.init 256 (fun code -> fun_charset (Char.unsafe_chr code)) in
+ fun c -> Array.unsafe_get table (Char.code c)
@@ -1,5 +1,5 @@
(*
- Copyright © 2011 MLstate
+ Copyright © 2011, 2012 MLstate
This file is part of OPA.
@@ -43,3 +43,4 @@ val is_alpha : char -> bool
*)
val is_space : char -> bool
val hexa_value : char -> int
+val cache : (char->bool) -> (char->bool)
View
@@ -624,14 +624,14 @@ let last_char s =
if len = 0 then invalid_arg "String.last_char" else
unsafe_get s (pred len)
+let rec aux_len_from func str len i =
+ if i<>len && func (unsafe_get str i) then aux_len_from func str len (i+1)
+ else i
+
let len_from func str index =
let len = length str in
- let max = len - index in
- let rec aux cur =
- if cur < max && func str.[index + cur] then aux (succ cur)
- else cur
- in
- aux 0
+ if 0 <= index && index < len then (aux_len_from func str len index)-index
+ else invalid_arg (Printf.sprintf "String.len_from(_,len=%d,%d)" len index)
let hash = Hashtbl.hash
@@ -1,5 +1,5 @@
(*
- Copyright © 2011 MLstate
+ Copyright © 2011, 2012 MLstate
This file is part of OPA.
View
@@ -1,5 +1,5 @@
(*
- Copyright © 2011 MLstate
+ Copyright © 2011, 2012 MLstate
This file is part of OPA.
@@ -20,8 +20,13 @@ module String = BaseString
(* -- *)
-let except_html_char = "\"&<>" (* normal characters that *should* be escaped in html *)
-let allowed_special_char = "\t\n\r" (* special characters that *should not* be escaped in html *)
+(* normal characters that *should* be escaped in html *)
+let except_html_char = "\"&<>"
+let fexcept_html_char = BaseChar.cache (String.contains except_html_char)
+
+(* special characters that *should not* be escaped in html *)
+let allowed_special_char = "\t\n\r"
+let fallowed_special_char = BaseChar.cache (String.contains allowed_special_char)
let string_of_int i =
let r1 i = Char.chr (((i mod 64) + 128)) in
@@ -39,30 +44,25 @@ let string_of_int i =
else assert false
(* takes any utf8 string and converts it into html entities (escape *all* characters, which is not avised in general; please perform checks before calling it) *)
-let htmlentities src =
- let rec pow n p = if p = 0 then 1 else (pow n (p - 1)) * n in
- let len = String.length src in
- let soi = Pervasives.string_of_int in
- let rec aux nbr pos i lst =
- if i = len then lst
- else
- let chr = Char.code src.[i] in
- if pos = (-1) then
- if chr >= 240 then aux ((chr mod 16) * 262144) 2 (i + 1) lst
- else if chr >= 224 then aux ((chr mod 32) * 4096) 1 (i + 1) lst
- else if chr >= 192 then aux ((chr mod 64) * 64) 0 (i + 1) lst
- else if (chr < 128 && (chr >= 32 || String.contains allowed_special_char src.[i])) || String.contains except_html_char src.[i]
- then aux 0 (-1) (i + 1) (chr::lst)
- else
- (* between 128 and 192: malformed UTF-8; we should absolutely not fail, but return the usual black question mark for invalid symbols *)
- (* between 0 and 31, except allowed_special_char, the entities seem to be illegal, so we project again to the question mark *)
- begin
- (* Journal.Interface.warning (Printf.sprintf "Warning: htmlentities: invalid UTF-8: in string %s at position %d on character of code %d" src i chr); *)
- aux 0 (-1) (i + 1) (65533::lst)
- end
- else
- let nbr = nbr + ((chr mod 64) * (pow 64 pos)) in
- if pos = 0 then aux 0 (-1) (i + 1) (nbr::lst)
- else aux nbr (pos - 1) (i + 1) lst
+let htmlentities_append buf src start len =
+ let unknown = 65533 in
+ let last = start+len in
+ let rec aux i =
+ if i=last then () else (
+ let char_code = Cactutf.look src i in
+ let next_i = try Cactutf.next src i with _ -> (* bad utf8 *) i+1 in
+ let char_ok = (char_code >= 32 || fallowed_special_char src.[i]) (* control char *)
+ (*&& (char_code <= 128 || fexcept_html_char src.[i]) *) (* Useless *)
+ in
+ Buffer.add_string buf "&#";
+ Buffer.add_string buf (Pervasives.string_of_int (if char_ok then char_code else unknown));
+ Buffer.add_char buf ';';
+ aux next_i
+ )
in
- List.fold_right (fun item acc -> acc^"&#"^(soi item)^";") (aux 0 (-1) 0 []) ""
+ aux start
+
+let htmlentities src =
+ let buf = Buffer.create ((String.length src) * ( (*String.length "&#00;"*)3 + 2 )) in
+ htmlentities_append buf src 0 (String.length src);
+ Buffer.contents buf
@@ -1,5 +1,5 @@
(*
- Copyright © 2011 MLstate
+ Copyright © 2011, 2012 MLstate
This file is part of OPA.
@@ -18,4 +18,7 @@
val except_html_char : string
val allowed_special_char : string
val string_of_int : int -> string
+(* escape all chars to html entities using a formater taking starting position and number of char to process *)
+val htmlentities_append : Buffer.t -> string -> int -> int -> unit
+(* escape all chars to html entities *)
val htmlentities : string -> string
View
@@ -1,5 +1,5 @@
(*
- Copyright © 2011 MLstate
+ Copyright © 2011, 2012 MLstate
This file is part of OPA.
@@ -159,6 +159,10 @@ val uppercase : string -> string
*)
val lowercase : string -> string
+(**
+ check utf8 validity
+*)
+val check : string -> bool
(**
{6 Deprecated}
@@ -147,7 +147,9 @@ let add_fetched str fetched =
-define (StarFetch (num:int, result)) = "* " num " FETCH " result "\r\n"
-define (FetchContinue (what, len:int)) = " " what " {" len "}\r\n"
-define FetchEnd = ")\r\n"
+-define (StarListLen (flags,rf,len:int)) = "* LIST ("~ flags ") " rf " {" len "}\r\n"
-define (StarList (flags,rf,mailbox)) = "* LIST ("~ flags ") " rf " " mailbox "\r\n"
+-define (StarStatusLen (len:int)) = "* STATUS {" len "}\r\n"
-define (StarStatus (mailbox,items)) = "* STATUS "~ mailbox " (" items ")\r\n"
-define (Search (tag, params)) = tag " SEARCH " params "\r\n"
-define (UidSearch (tag, params)) = tag " UID SEARCH " params "\r\n"
@@ -189,6 +191,8 @@ let add_fetched str fetched =
-define (JustNo (tag,str)) = tag " NO " str "\r\n"
-define (JustBad (tag,str)) = tag " BAD " str "\r\n"
+-define StatusLenEnd items = " (" items ")\r\n"
+-define End = "\r\n"
-define RawInput str = str
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
@@ -303,6 +307,7 @@ commands(mail, tools):
error({{ "Empty strings would make LIST command invalid, use \"\" instead" }}, tools)
else
send (List (tag, rf, mailbox));
+ let mail = {{ { mail with list = [] } }}
list(mail, tools, tag)
end
| ImapCopy (uid, seq, mailbox) ->
@@ -327,6 +332,7 @@ commands(mail, tools):
error({{ "Empty strings would make STATUS command invalid, use \"\" instead" }}, tools)
else
send (Status (tag, mailbox, items));
+ let mail = {{ { mail with statused = [] } }}
status(mail, tools, tag)
end
| ImapAppend (mailbox, flags, time, msg) ->
@@ -555,7 +561,10 @@ list(mail, tools, tag):
| StarOk _str ->
debug {{ eprintf "list received * OK: %s\n" _str }}
list(mail, tools, tag)
+ | StarListLen (flags, rf, len) ->
+ list_data(mail, tools, tag, flags, rf, len)
| StarList (flags, rf, mailbox) ->
+ let mailbox = {{ String.strip_quotes mailbox }}
debug {{ eprintf "list received * LIST: (%s) %s %s\n" flags rf mailbox }}
let mail = {{ { mail with list = ((flags,rf,mailbox)::mail.list) } }}
list(mail, tools, tag)
@@ -574,12 +583,33 @@ list(mail, tools, tag):
| exn ->
check_exception(mail, tools, {{"list"}}, tag, exn)
+list_data(mail, tools, tag, flags, rf, len):
+ debug {{ eprintf "list_data: getting %d bytes\n%!" len }}
+ fixed {{ len }}
+ | mailbox ->
+ debug {{ eprintf "list received * LIST: (%s) %s %s\n" flags rf mailbox }}
+ let mail = {{ { mail with list = ((flags,rf,mailbox)::mail.list) } }}
+ list_end(mail, tools, tag)
+
+list_end(mail, tools, tag):
+ receive
+ | End ->
+ debug {{ eprintf "list_data: ok\n%!" }}
+ list(mail, tools, tag)
+ | err ->
+ debug {{ eprintf "list_data: error\n%!" }}
+ error({{ sprintf "Bad end of list data: %s" (String.escaped (string_of_msg err)) }}, tools)
+
status(mail, tools, tag):
receive
| StarOk _str ->
debug {{ eprintf "status received * OK: %s\n" _str }}
status(mail, tools, tag)
+ | StarStatusLen len ->
+ status_data(mail, tools, tag, len)
| StarStatus (mailbox, items) ->
+ let mailbox = {{ String.strip_quotes mailbox }}
+ debug {{ eprintf "mailbox(hdr) = '%s'\n%!" mailbox }}
debug {{ eprintf "status received * STATUS: %s (%s)\n" mailbox items }}
let mail = {{ { mail with statused = ((mailbox,items)::mail.statused) } }}
status(mail, tools, tag)
@@ -598,6 +628,24 @@ status(mail, tools, tag):
| exn ->
check_exception(mail, tools, {{"status"}}, tag, exn)
+status_data(mail, tools, tag, len):
+ debug {{ eprintf "status_data: getting %d bytes\n%!" len }}
+ fixed {{ len }}
+ | mailbox ->
+ debug {{ eprintf "mailbox(len) = '%s'\n%!" mailbox }}
+ debug {{ eprintf "status received * STATUS: %s\n" mailbox }}
+ status_end(mail, tools, tag, mailbox)
+
+status_end(mail, tools, tag, mailbox):
+ receive
+ | StatusLenEnd items ->
+ debug {{ eprintf "status_data: ok\n%!" }}
+ let mail = {{ { mail with statused = ((mailbox,items)::mail.statused) } }}
+ status(mail, tools, tag)
+ | err ->
+ debug {{ eprintf "status_data: error\n%!" }}
+ error({{ sprintf "Bad end of status data: %s" (String.escaped (string_of_msg err)) }}, tools)
+
append(mail, tools, tag, msg):
receive
| Ready _str ->
@@ -20,6 +20,7 @@
Private module for DB-Accessors generation.
@author Louis Gesbert
@author Mathieu Barbin (errors report)
+ @author Quentin Bourgerie
*)
(* depends *)
@@ -123,7 +124,9 @@ module Default = struct
match select with
| DbAst.SFlds flds ->
(fun fld ->
- List.find_map (fun (flds, s) -> if flds = [fld] then Some s else None) flds
+ List.find_map
+ (fun (flds, s) -> if flds = [`string fld] then Some s else None)
+ flds
)
| _ -> (fun _ -> Some (DbAst.SStar))
in
@@ -1678,9 +1681,9 @@ module CodeGenerator ( Arg : DbGenByPass.S ) = struct
let flds =
List.map
(function
- | [f], Db.UExpr expr -> f, expr
- | [f], Db.UFlds flds ->
- f, build_record flds (Schema_private.dots gamma [f] ty)
+ | [`string f], Db.UExpr expr -> f, expr
+ | ([`string f] as f0), Db.UFlds flds ->
+ f, build_record flds (Schema_private.dots gamma f0 ty)
| _ -> error ()
)
flds
Oops, something went wrong.

0 comments on commit 8b87a09

Please sign in to comment.