/pliant/protocol/http/uvar.pli
 
 1  abstract 
 2    [Per user permanent variables for the HTTP server.] 
 3   
 4   
 5  # Copyright  Hubert Tonneau  hubert.tonneau@pliant.cx 
 6  # 
 7  # This program is free software; you can redistribute it and/or 
 8  # modify it under the terms of the GNU General Public License version 2 
 9  # as published by the Free Software Foundation. 
 10  # 
 11  # This program is distributed in the hope that it will be useful, 
 12  # but WITHOUT ANY WARRANTY; without even the implied warranty of 
 13  # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the 
 14  # GNU General Public License for more details. 
 15  # 
 16  # You should have received a copy of the GNU General Public License 
 17  # version 2 along with this program; if not, write to the Free Software 
 18  # Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA. 
 19   
 20   
 21  module "/pliant/language/compiler.pli" 
 22  module "/pliant/fullpliant/user.pli" 
 23  module "server.pli" 
 24  submodule "/pliant/storage/database.pli" 
 25  module "/pliant/storage/database/prototype.pli" 
 26  module "/pliant/language/data/string_cast.pli" 
 27   
 28   
 29  type DataConstant 
 30    field Arrow value 
 31     
 32  DataInterface_ maybe DataConstant 
 33   
 34  method dd type d -> t 
 35    oarg DataConstant dd ; arg Data_ d ; arg_R Type t 
 36    t :> entry_type dd:value 
 37   
 38  method dc get d adr type -> status 
 39    oarg DataConstant dc ; arg Data_ d ; arg Address adr ; arg Type type ; arg Status status 
 40    var Pointer:Type t :> entry_type dc:value 
 41    if type=t 
 42      type copy_instance dc:value adr 
 43      status := success 
 44    else 
 45      var Str s := to_string dc:value t "db" 
 46      status := from_string adr type s "db" 
 47   
 48   
 49  type UserVariable 
 50    field Str module 
 51    field Str variable 
 52    field Link:Type type 
 53    field Link:DataConstant default 
 54   
 55  function uvar_map page uv d 
 56    arg HtmlPage page ; arg UserVariable uv ; arg_rw Data_ d 
 57    var Str uname := page:http_request user_name 
 58    if uname="" 
 59      d := data_null 
 60      if (exists uv:default) 
 61        d interface :> uv default 
 62      return 
 63    var Data:(Set Set:Anything) session :> user_database2:data:user:uname:session 
 64    if not (exists session) 
 65      user_database2:data:user create uname 
 66      session :> user_database2:data:user:uname:session 
 67    var (Pointer Data:Anything) data :>> addressof:d map Data:Anything 
 68    data :> (session uv:module) uv:variable 
 69    if d:adr=null # FIXME: should be: not exists:data 
 70      session create uv:module 
 71      (session uv:module) create uv:variable 
 72      data :> (session uv:module) uv:variable 
 73      if (exists uv:default) 
 74        d:base:sem request 
 75        d:interface set d uv:default:value (entry_type uv:default:value) 
 76        d:base:sem release 
 77   
 78  function active_type uv access e 
 79    arg UserVariable uv ; arg Int access ; arg_rw Expression e 
 80    if e:size<>1 or not (e:0 cast HtmlPage) 
 81      return 
 82    e suckup e:0 
 83    var Link:Argument a :> argument local (Data uv:type) 
 84    e add (instruction (the_function uvar_map HtmlPage UserVariable Data_) e:0:result (argument mapped_constant UserVariable uv) a) 
 85    e set_result a access_read+access_write 
 86   
 87   
 88  meta uvar e 
 89    if e:size<2 or (e:0 constant Type)=null 
 90      return 
 91    var Pointer:Type t :> (e:0 constant Type) map Type 
 92    var Link:DataConstant default :> null map DataConstant 
 93    var Int stop := e:size 
 94    if e:size>=4 and e:(e:size-2):ident="<-" and (e:(e:size-1) constant t)<>null 
 95      default :> new DataConstant 
 96      default value := e:(e:size-1) constant t 
 97      stop -= 2 
 98    for (var Int i) 1 stop-1 
 99      if not e:i:is_pure_ident 
 100        return 
 101    for (var Int i) 1 stop-1 
 102      var Link:UserVariable uv :> new UserVariable 
 103      uv module := e:external_module:name 
 104      uv variable := e:i ident 
 105      uv type :> t 
 106      uv default :> default 
 107      e define ". "+e:i:ident addressof:uv e:module:actual 
 108    e set_void_result 
 109   
 110  export uvar