/pliant/protocol/http/style/common.style
 
 1  # Copyright  Hubert Tonneau  hubert.tonneau@pliant.cx 
 2  # 
 3  # This program is free software; you can redistribute it and/or 
 4  # modify it under the terms of the GNU General Public License version 2 
 5  # as published by the Free Software Foundation. 
 6  # 
 7  # This program is distributed in the hope that it will be useful, 
 8  # but WITHOUT ANY WARRANTY; without even the implied warranty of 
 9  # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the 
 10  # GNU General Public License for more details. 
 11  # 
 12  # You should have received a copy of the GNU General Public License 
 13  # version 2 along with this program; if not, write to the Free Software 
 14  # Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA. 
 15   
 16  module "/pliant/language/stream.pli" 
 17  module "/pliant/language/stream/filesystembase.pli" 
 18  module "/pliant/language/compiler.pli" 
 19  module "/pliant/language/parser.pli" 
 20  module "/pliant/admin/file.pli" 
 21  module "/pliant/protocol/http/server.pli" 
 22  module "/pliant/protocol/common/mime.pli" 
 23  module "common.pli" 
 24   
 25   
 26 
 
 27  #  basic 
 28   
 29   
 30  method p replace_content replace with -> status 
 31    arg_rw HtmlPage p ; arg Str replace with ; arg Status status 
 32    var Pointer:Stream stream :> http_stream 
 33    var Address start := stream stream_write_buf 
 34    var Address cur := stream stream_write_cur 
 35    var Address stop := stream stream_write_stop 
 36    if (cast stop Int).-.(cast cur Int) >= with:len-replace:len 
 37      var Address := memory_search start (cast cur Int).-.(cast start Int) replace:characters replace:len 
 38      if a<>null 
 39        memory_move (translate Byte replace:len) (translate Byte with:len) (cast cur Int).-.(cast Int)-replace:len 
 40        memory_copy with:characters with:len 
 41        stream stream_write_cur := cur translate Byte with:len-replace:len 
 42        return success 
 43    status := failure 
 44   
 45  method p head s -> status 
 46    arg_rw HtmlPage p ; arg Str s ; arg Status status 
 47    replace_content "</head>" s+"</head>" 
 48   
 49  method p flush 
 50    arg_rw HtmlPage p 
 51    p:http_stream flush anytime 
 52   
 53  function 'cast Status' p -> s 
 54    arg HtmlPage p ; arg Status s 
 55    := cast p:http_stream Status 
 56   
 57   
 58  method p virtual_command -> c 
 59    arg HtmlPage p ; arg_C Str c 
 60    :> p:http_request command 
 61   
 62   
 63  method p language -> l 
 64    arg HtmlPage p ; arg_C Str l 
 65    :> p:http_request language 
 66   
 67   
 68  export '. replace_content' '. head' '. flush' 'cast Status' '. virtual_command' '. language' 
 69   
 70   
 71 
 
 72  #  authentification 
 73   
 74   
 75  method p user_name -> u 
 76    arg HtmlPage p ; arg Str u 
 77    := p:request user_name 
 78   
 79  method p allowed name -> a 
 80    arg HtmlPage p ; arg Str name ; arg CBool a 
 81    := p:request allowed name 
 82   
 83  method p is_not_allowed name -> failed 
 84    arg_rw HtmlPage p ; arg Str name ; arg CBool failed 
 85    failed := not (p:request allowed name) 
 86    if failed 
 87      reset_http_answer 
 88      p:request send_authentification_request 
 89   
 90  meta requires e 
 91    if e:size=and (e:cast Str) 
 92      compile_as (expression immediat (if is_not_allowed:name return) substitute name e:0) 
 93   
 94  export '. user_name' '. allowed' requires '. is_not_allowed' 
 95   
 96   
 97 
 
 98  #  [] inline text 
 99   
 100   
 101  function active_type itext access e 
 102    arg InlineText itext ; arg Int access ; arg_rw Expression e 
 103    if ("[dq]"+(addressof:itext map Str)+"[dq]" parse (var Str t)) 
 104      var Link:Str text :> new Str t 
 105      if e:size=0 
 106        compile_as (expression immediat (page text t) substitute t (expression constant text near e)) 
 107   
 108   
 109 
 
 110  # driving the browser 
 111   
 112   
 113  method page goto_hyperlink target autoext section options 
 114    arg_rw HtmlPage page ; arg Str target ; arg CBool autoext ; arg Str section options 
 115    var Str without_path := target (target search_last "/" -1)+target:len 
 116    var Str := http_encode target 
 117    if autoext and without_path:len<>and (without_path search "." -1)=(-1) and (without_path search ":" -1)=(-1) 
 118      += ".html" 
 119    if section<>"" 
 120      += "#"+http_encode:section 
 121    if options<>"" 
 122      += "?"+http_encode:options 
 123    page:http_request answer_is_dynamic := true 
 124    page html "<script language=[dq]JavaScript[dq]>[lf]" 
 125    page html "  location.replace([dq]"+t+"[dq])[lf]" 
 126    page html "</script>[lf]" 
 127    page html "Your browser is not very smart. You should select <a href=[dq]"+t+"[dq]>this link</a> to get the right page." 
 128     
 129  meta '. goto_url' e 
 130    if e:size<or not (e:cast HtmlPage) or not (e:cast Str) 
 131      return 
 132    suckup e:0 ; suckup e:1 
 133    var Link:Argument autoext :> argument constant CBool true 
 134    var Link:Argument section :> argument constant Str "" 
 135    var Link:Argument options :> argument constant Str "" 
 136    var Int := 2 
 137    while i<e:size 
 138      if e:i:ident="no_extension" 
 139        autoext :> argument constant CBool false 
 140        += 1 
 141      eif e:i:ident="section" and i+1<e:size and (e:(i+1) cast Str) 
 142        suckup e:(i+1) 
 143        section :> e:(i+1):result 
 144        += 2 
 145      eif e:i:ident="options" and i+1<e:size and (e:(i+1) cast Str) 
 146        suckup e:(i+1) 
 147        options :> e:(i+1):result 
 148        += 2 
 149      else 
 150        return 
 151    add (instruction (the_function '. goto_hyperlink' HtmlPage Str CBool Str Str) e:0:result e:1:result autoext section options) 
 152    set_void_result 
 153   
 154   
 155  method page goto_backward n 
 156    arg_rw HtmlPage page ; arg Int n 
 157    page:http_request answer_is_dynamic := true 
 158    page html "<script language=[dq]JavaScript[dq]>[lf]" 
 159    var Int := undefined ; var Int := undefined 
 160    part search 
 161      if n=0 
 162        if ("&"+page:http_request:form+"&" eparse any "&_pliant_x=" (var Int x) "&" any) and ("&"+page:http_request:form+"&" eparse any "&_pliant_y=" (var Int y) "&" any) 
 163          leave search 
 164        eif (page:http_request:encoded_options parse "button+" (var Int x) "+" (var Int y) "+" any) 
 165          leave search 
 166      eif n=1 
 167        var Pointer:Arrow :> page:http_request:query_log first 
 168        while c<>null 
 169          if ((map Str) parse acword:"referer" ":" any "?button+" "+" "+" any) 
 170            leave search 
 171          :> page:http_request:query_log next c 
 172    if x=defined and y=defined 
 173      var Str spos := (character 65+x\17576)+(character 65+x\676%26)+(character 65+x\26%26)+(character 65+x%26)+(character 65+y\17576)+(character 65+y\676%26)+(character 65+y\26%26)+(character 65+y%26) 
 174      page html "    window.name = '_xy_"+spos+"_'+window.name[lf]" 
 175    if page:http_request:browser_model="netscape" 
 176      page html "  window.history.go(-"+(string n+1)+")[lf]" 
 177    eif page:http_request:browser_model="ie" and page:http_request:browser_release<or page:http_request:browser_model="mozilla" and page:http_request:browser_release>=1.5 
 178      page html "  window.name = '_reload_'+window.name[lf]" 
 179      page html "  window.history.go(-"+(string n+1)+")[lf]" 
 180    else # Mozilla 0.9.8, IE 6, Opera 6 and Konqueror, FireFox <1.5 
 181      page html "  window.name = '_back_"+(character 65+n)+"__reload_'+window.name[lf]" 
 182    page html "</script>[lf]" 
 183    page html "<p>Now computing ...</p><p><font size=[dq]-1[dq]>If your browser is not smart enough to switch back automatically when the computation is over, then you'll have to press the Back button "+(string n+1)+" time"+(shunt n>="s" "")+" and then the reload button.</font></p>" 
 184   
 185  method page reload_page 
 186    arg_rw HtmlPage page 
 187    page goto_backward 0 
 188   
 189  method page goto_backward 
 190    arg_rw HtmlPage page 
 191    page goto_backward 1 
 192   
 193   
 194  export '. goto_url' '. reload_page' '. goto_backward' 
 195   
 196   
 197   
 198   
 199