/pliant/language/type/text/language.pli
 
 1  # Copyright  Hubert Tonneau  hubert.tonneau@pliant.cx 
 2   
 3  module "/pliant/language/compiler.pli" 
 4  module "/pliant/language/schedule/threads_engine.pli" 
 5  module "/pliant/language/parser.pli" 
 6  module "/pliant/admin/file.pli" 
 7  module "/pliant/language/stream.pli" 
 8   
 9  gvar Array:Str languages 
 10  gvar (Dictionary Str Int) mapping 
 11  gvar Sem sem 
 12   
 13  languages += "en" 
 14  mapping insert "en" 0 
 15   
 16   
 17  function language_declare name -> index 
 18    arg Str name ; arg Int index 
 19    sem request 
 20    var Pointer:Int pindex :> mapping first name 
 21    if exists:pindex 
 22      index := pindex 
 23    else 
 24      index := mapping size 
 25      languages += name 
 26      mapping insert name index 
 27    sem release 
 28   
 29  function language_index name -> index 
 30    arg Str name ; arg Int index 
 31    sem rd_request 
 32    var Pointer:Int pindex :> mapping first name 
 33    index := shunt exists:pindex pindex (cast undefined Int) 
 34    sem rd_release 
 35   
 36  function language_list -> langs 
 37    arg Array:Str langs 
 38    sem rd_request 
 39    langs := languages 
 40    sem rd_release 
 41   
 42   
 43  type lStr 
 44    field Address buffer 
 45    field Int nlang 
 46   
 47   
 48  function build l 
 49    arg_w lStr l 
 50    buffer := null 
 51    nlang := 0 
 52   
 53  function destroy l 
 54    arg_w lStr l 
 55    memory_free l:buffer 
 56   
 57  function copy s d 
 58    arg lStr s ; arg_w lStr d 
 59    var Int size := s:nlang*Int:size+(shunt s:nlang=0 0 (s:buffer map Int s:nlang-1)) 
 60    memory_free d:buffer 
 61    buffer := memory_allocate size addressof:d 
 62    memory_copy s:buffer d:buffer size 
 63    nlang := nlang 
 64   
 65   
 66  method l set lang value 
 67    arg_rw lStr l ; arg Int lang ; arg Str value 
 68    check lang>=and lang<mapping:size 
 69    var Int len 
 70    if lang>=and lang<l:nlang 
 71      var Int off := shunt lang<>0 (l:buffer map Int lang-1) 0 
 72      len := (l:buffer map Int lang)-off 
 73    else 
 74      len := 0 
 75    len := (shunt l:nlang=0 0 (l:buffer map Int l:nlang-1))+value:len-len 
 76    var Int nlang := max l:nlang lang+1 
 77    var Address buffer := memory_allocate nlang*Int:size+len addressof:l 
 78    var Int offset := 0 
 79    for (var Int i) nlang-1 
 80      var Address src ; var Int len 
 81      if i=lang 
 82        len := value len 
 83        src := value characters 
 84      eif i<l:nlang 
 85        var Int off := shunt i<>0 (l:buffer map Int i-1) 0 
 86        len := (l:buffer map Int i)-off 
 87        src := (l:buffer translate Int l:nlang) translate Char off 
 88      else 
 89        len := 0 
 90      memory_copy src ((buffer translate Int nlang) translate Char offset) len 
 91      offset += len 
 92      buffer map Int := offset 
 93    memory_free l:buffer 
 94    buffer := buffer 
 95    nlang := nlang 
 96   
 97   
 98  method l set lang value 
 99    arg_rw lStr l ; arg Str lang ; arg Str value 
 100    var Int index := language_index lang 
 101    if index<>undefined 
 102      set index value 
 103   
 104   
 105  method l get lang -> s 
 106    arg lStr l ; arg Int lang ; arg Str s 
 107    check lang>=0 
 108    if lang<l:nlang 
 109      var Int offset := shunt lang<>0 (l:buffer map Int lang-1) 0 
 110      var Int len := (l:buffer map Int lang)-offset 
 111      set ((l:buffer translate Int l:nlang) translate Char offset) len false 
 112    else 
 113      := "" 
 114  ((the_function '. get' lStr Int -> Str) arg 2) maps := 1 
 115   
 116  method l get lang -> value 
 117    arg lStr l ; arg Str lang ; arg Str value 
 118    var Int index := language_index lang 
 119    if index<>undefined 
 120      value := get index 
 121    else 
 122      value := "" 
 123  ((the_function '. get' lStr Str -> Str) arg 2) maps := 1 
 124   
 125   
 126  function 'cast Str' l -> s 
 127    arg lStr l ; arg Str s 
 128    extension 
 129    var Int index := current_thread_header language_index 
 130    := get index 
 131    if s:len=and index<>0 
 132      := get 0 
 133  ((the_function 'cast Str' lStr -> Str) arg 1) maps := 1 
 134   
 135   
 136  export language_declare language_index language_list 
 137  export lStr '. get' '. set' 
 138  export 'cast Str' 
 139   
 140   
 141  function parse_lstr context line parameter 
 142    arg_rw ParserContext context ; arg Str line ; arg Address parameter 
 143    if (line 0 1)<>"[dq]" 
 144      return 
 145    var Int := 1 
 146    var Link:lStr :> new lStr 
 147    var Str lang := "en" 
 148    var CBool some := false 
 149    while i<line:len 
 150      if line:i="[dq]" 
 151        if some 
 152          var Str name := context:module name 
 153          name := name 0 (name search_last "." name:len) 
 154          var Array:FileInfo files := file_list (name 0 (name search_last "/" name:len)+1) standard 
 155          for (var Int j) files:size-1 
 156            var Str ext := files:j:extension 
 157            if (files:j:name name:len)=name and files:j:name<>context:module:name and (ext 0 1)="." 
 158              (var Stream file) open files:j:name in+safe 
 159              while not file:atend 
 160                if (file:readline parse (var Str en) (var Str translation)) 
 161                  if en=(get 0) 
 162                    language_declare (ext ext:len) 
 163                    set (ext ext:len) translation 
 164          context add_token addressof:l 
 165          context forward i+1 
 166        return 
 167      eif line:i="[lb]" 
 168        if ((line line:len) eparse "[lb]" any:(var Str code) "[rb]" any) 
 169          if code="l" 
 170            some := true 
 171          eif code:len>and (code code:len-1)=":" 
 172            lang := code code:len-1 ; language_declare lang ; some := true 
 173          eif ("[dq][lb]"+code+"[rb][dq]" parse (var Str char)) 
 174            set lang (get lang)+char 
 175          else 
 176            return 
 177          += 2+code:len 
 178        else 
 179          return 
 180      else 
 181        set lang (get lang)+line:i 
 182        += 1 
 183   
 184  gvar ParserFilter lstr_filter 
 185  lstr_filter function :> the_function parse_lstr ParserContext Str Address 
 186  constant 'pliant parser basic types' lstr_filter 
 187  export 'pliant parser basic types' 
 188   
 189   
 190  function language_encode l -> s 
 191    arg lStr l ; arg Str s 
 192    := "" 
 193    for (var Int i) l:nlang-1 
 194      var Str := get i 
 195      if v:len>0 
 196        += (shunt s:len>" " "")+languages:i+" "+string:v 
 197   
 198  function language_decode s create_langs -> l 
 199    arg Str s ; arg CBool create_langs ; arg lStr l 
 200    := var lStr empty_string 
 201    var Str all := s 
 202    while (all parse any:(var Str lang) _ (var Str value) any:(var Str remain)) 
 203      if create_langs 
 204        set lang value 
 205      else 
 206        var Int index := language_index lang 
 207        if index<>undefined 
 208          set index value 
 209      all := remain 
 210   
 211  export language_encode language_decode 
 212   
 213   
 214  method data 'to string' options -> string 
 215    arg lStr data ; arg Str options ; arg Str string 
 216    if options="raw" 
 217      string := language_encode data 
 218    eif options="db" or options="con" 
 219      string := cast data Str 
 220    else 
 221      string := string (cast data Str) 
 222   
 223  method data 'from string' string options may_skip skiped offset -> status 
 224    arg_w lStr data ; arg Str string options ; arg CBool may_skip ; arg_w Int skiped offset ; arg Status status 
 225    if options="raw" 
 226      data := language_decode string false 
 227      skiped := 0 
 228      offset := string len 
 229      return success 
 230    eif options="db" or options="con" 
 231      data set (current_thread_header language_index) string 
 232      skiped := 0 
 233      offset := string len 
 234      return success 
 235    else 
 236      var Link:Str :> new Str 
 237      status := 'from string' string options may_skip skiped offset 
 238      data set (current_thread_header language_index) s