tclhttpd-users — Discussion and general Q&A for TclHttpd

[Tclhttpd-users] failed to upload files to server

[Sailer H. (ext.) <Hol...@ks...>]

Hello,

I'm trying to post files to the server in two ways:
 
1. via cgi: posting an file fails due to:
    in cgi.tcl: proc CgiSpawn: 
             fcopy $sock $fd -command [list CgiCopyDone $sock $fd] -size
$data(count)
   -> dependent on size of posted file, CgiCopyDone never got called. 

    cgifile.tml:
            <form ENCtype="multipart/form-data"
action="/cgi-bin/testupload.cgi" method="post">
 
---------------------------------
             File <input type="file" name="the_file" accept="application/*">
             <p>
             <input type=submit>
             </form>
   
      cgi-bin/testupload.tcl:
              puts "Content-Type: text/html"
              puts <pre>
              fconfigure stdin -translation binary
              puts [read stdin $env(CONTENT_LENGTH)]
              puts </pre>

-------------------------------------------------------------

2. post file by not calling cgi-process:
   -> works with all ascii-files as well as binary files <  ~ 80 KB.
       fails with bigger binary files.
       e.g. compressed tar - archives can't be extracted any more.

    myfile.tml:
    ---------------
            <form ENCtype="multipart/form-data" action="mytestupload.tml"
method="post">
 
-------------------------
             File <input type="file" name="the_file" accept="application/*">
             <p>
             <input type=submit>
             </form>

    mytestupload.tml:
    -------------------------

<table border=1 cellpadding=2>
[
    set html ""
    set fname "unknown.upload"
    foreach {n v} [ncgi::nvlist] {
        switch -- $n {
	   the_file {
	      foreach { vn vv } [lindex $v 0] {
	         append html "<pre> NAME=$vn  VALUE=$vv \n</pre>"
	         switch -- $vn {
		    filename {
		       regsub -all {\\} $vv {/} new
		       set fname [ file tail $new ]
		    }
		 }
	      }
	      set fd [ open [ file join / tmp $fname] w]
	      fconfigure $fd -translation binary
	      puts -nonewline $fd [ncgi::value the_file]
	      close $fd 
	      append html [html::h1 "File saved on [ file join / tmp
$fname]"]
	   }
	}
	append html [html::row $n [html::tableFromList [lindex $v 0]]]
    }
    set html
]
</table>


I'm using tclhttpd3.2.1 and tcl8.3 / tcl8.3.2 and tcllib0.8 (no threads).
I've tested on Win NT and QNX


Is there a bug or am i doing something wrong?
Thanks in advance,

Holger Sailer

   

Re: [Tclhttpd-users] Re: multiple clients

[Brent W. <bre...@in...>]

>>>Brent Welch said:

 > I've expanded this answer into the web page at
 > http://dev.scriptics.com/tclhttpd/threading.html

Gack - that should be
http://dev.scriptics.com/software/tclhttpd/threading.html

--	Brent Welch	<bre...@in...>
	http://www.interwoven.com

Re: [Tclhttpd-users] To thread, or not to thread?

[Brent W. <bre...@in...>]

For the normal web site, I don't see an urge to add threads.
I never did it for sunscript.sun.com or www.scriptics.com - did
those sites seem OK?  How do they feel in comparison with
dev.scriptics.com that uses AOLserver - heavily threaded but also
burdoned with database accesses - my measurements showed the home
page fetches for tclhttpd to be more than twice as fast as the
AOLserver fetches - primarly the database overhead, I'm sure.

If your custom domain handlers communicate with other processes via
pipes, then again I don't see a need for threads.  Do it similarly
to the CGI module, and then you should be able to use event-driven
I/O for everything.

Finally, set up a performance lab and blast your service.  You'll be
able to drive it harder than your initial customer load.  Then you
can compare both performance and reliability.

>>>Steve Blinkhorn said:
 > 
 > I would welcome some advice or shared experience as to the benefits or
 > otherwise of running tclhttpd with threads enabled.   Our intended use
 > is slightly unusual: one instance of the server will run something
 > like a normal website, with a software download available.   Said
 > software will then communicate with other instances
 > with custom domain handlers to do all sorts of fancy things.
 > 
 > There have been discussions over the past weeks and months in clt
 > which have ranged from the performance hit on thread-enabled
 > tcl, to possible flakiness of the implementation (do I remember this
 > correctly?).   Is there experience with tclhttpd in particular which
 > would help us decide whether enabling threads would on balance be
 > beneficial, and which release of tcl is considered most stable in this
 > respect?
 > 
 > Because the site in question is an entirely new (and rather different)
 > enterprise, we don't have any sensible estimate of the hit rate we may
 > expect.   We would like to generate 100,000 initial contacts in the
 > first year, which is peanuts I suppose in terms of normal dot.com
 > activity.   The conventional browseable part of the site has been designed f
     or
 > speed of access and simplicity of use.   The software download is of
 > the order of 1 Mbyte.   The fancy custom domain handler stuff will
 > spawn other processes and manage file transfers, but these files will
 > be of the order of tens of kilobytes on any one occasion.
 > 
 > I don't know if the above is enough to prompt useful comment - but the
 > traffic on this list seems to me invariably helpfu, so I live in hope.
 > 
 > _______________________________________________
 > TclHttpd-users mailing list
 > Tcl...@li...
 > http://lists.sourceforge.net/lists/listinfo/tclhttpd-users

--	Brent Welch	<bre...@in...>
	http://www.interwoven.com

[Tclhttpd-users] Re: multiple clients

[Brent W. <bre...@in...>]

>>>Jonathan Clark said:

 >      Could you point me to any place that explains the ability of the
 > tclhttpd to handle simultaneous hits from multiple clients- does this
 > involve locking?
 >  Thankyou,
 >      Jonathan.

By default, TclHttpd uses non-blocking, event-driven I/O to multiplex itself 
among
multiple client hits.  It takes 1000's of hits daily on big web sites.

What happens when the server blocks while servicing a request?
There are 3 answers:

1) If the request is for a CGI application, then TclHttpd runs the
CGI process and communicates with it via a pipe.  The Tcl event loop means
that TclHttpd only runs when there is data available on the pipe.
So, the CGI process can block arbitrarily long and TclHttpd is free
to service other I/O requests, such as connections from new clients.

2) If the server would block because the client has a slow network
connection, then because it uses non-blocking I/O, well, it doesn't block.
Instead, it relies on the Tcl event loop to trigger a fileevent when
there is new data comming from the client, or when the write socket to
the client drains its output buffer.

3) If the server blocks for some other reason it can indeed starve clients.
The most typical example is if you make SQL calls to a database server directly
from TclHttpd.  Those calls will block until the SQL server returns the answer.
Right now the OraTcl and SybTcl interfaces do not really support a non-blocking
interface that will free up TclHttpd to get back into its event loop.

So:
3a) don't do that - if you are just serving files and short-running
dynamic pages, then it doesn't matter.  So what if you use some CPU time
to compute a page.  Passing that request off to another process (a la Apache)
or another thread (a la AOLserver) only helps on a multiprocessor.
On a uniprocessor, those approaches just add overhead.

3b) or, enable threading the TclHttpd.  This requires a recompile of
Tcl with the --enable-thread configure option, and the use of the Thread
extension.  You can get this with TclHttpd "Bundled distribution".
With threading, TclHttpd can pass requests to worker threads.

I've expanded this answer into the web page at
http://dev.scriptics.com/tclhttpd/threading.html

--	Brent Welch	<bre...@in...>
	http://www.interwoven.com

[Tclhttpd-users] To thread, or not to thread?

[Steve B. <st...@pr...>]

I would welcome some advice or shared experience as to the benefits or
otherwise of running tclhttpd with threads enabled.   Our intended use
is slightly unusual: one instance of the server will run something
like a normal website, with a software download available.   Said
software will then communicate with other instances
with custom domain handlers to do all sorts of fancy things.

There have been discussions over the past weeks and months in clt
which have ranged from the performance hit on thread-enabled
tcl, to possible flakiness of the implementation (do I remember this
correctly?).   Is there experience with tclhttpd in particular which
would help us decide whether enabling threads would on balance be
beneficial, and which release of tcl is considered most stable in this
respect?

Because the site in question is an entirely new (and rather different)
enterprise, we don't have any sensible estimate of the hit rate we may
expect.   We would like to generate 100,000 initial contacts in the
first year, which is peanuts I suppose in terms of normal dot.com
activity.   The conventional browseable part of the site has been designed for
speed of access and simplicity of use.   The software download is of
the order of 1 Mbyte.   The fancy custom domain handler stuff will
spawn other processes and manage file transfers, but these files will
be of the order of tens of kilobytes on any one occasion.

I don't know if the above is enough to prompt useful comment - but the
traffic on this list seems to me invariably helpfu, so I live in hope.

[Tclhttpd-users] Re: TclHttpd-users digest, Vol 1 #23 - 1 msg

[Peter F. <pet...@zv...>]

> From: "Ashwini Kumar" <ash...@ho...>
> 
> Hello,
> 
>         I am responsible for the selection of an appropriate web server for our new
> project. We are looking for an embeddable web server and two of the
> strongest contenders are Apache and Tcl Web server.
> 
>         I have had some great past experiences with TCL and would like to
> support Scriptics efforts. Therefore, could you please point me to some
> links which would objectively compare Tcl web server with Apache. Your own
> opinions would be greatly appreciated.
> 


I actually dont know of any existing comparisons. I dont see that there
is any comparison in the embeddability stakes though, embedding apache
seems like a much bigger task. APache has more features and better
performance. TclHttpd runs on more platforms (and doesnt need to be
compiled 8-). I use both, but in different situations.


-- 
Peter Farmer            | Custom XML software   | Internet Engineering 
Zveno Pty Ltd           | Website XML Solutions | Training & Seminars
http://www.zveno.com/   |   Open Source Tools   |   - XML XSL Tcl
Pet...@zv...  +-----------------------+---------------------
Ph. +61 8 92434146      | Mobile 0417 906 851   | Fax +61 2 6242 4099

Re: [Tclhttpd-users] Tcl Web Server vs Apache

[Brent W. <bre...@in...>]

I don't know of any objective comparisons up on the web.
I can say that:
Apache will be faster, especially for static pages.
But, TclHttpd is still quite zippy and should do, especially
if what you plan is some sort of management interface.

TclHttpd is super flexible, and designed to embedded.

Apache is not designed for embedding in the same way - it wants to
be in control.  It has a heavy-weight process architecture,
unless you want to wait for version 2 to come out of beta.
Because Apache wants to dispatch each URL request to a different
process, it can be awkward to use that architecture to control your
application. You may need to invent some other communication channel,
either shared memory or another socket, to get from your URL handler
back to the application you are trying to manage.

Both support SSL.  Some folks have found that configuring Tcl and the
TLS extension that provides SSL tricky, but it certainly can be made
to work.  There are folks on this list that can help.

TclHttpd is used in various production envrionments, and so
is Apache, of course.

>>>"Ashwini Kumar" said:
 > Hello,
 > 
 > 	I am responsible for the selection of an appropriate web server for our
      new
 > project. We are looking for an embeddable web server and two of the
 > strongest contenders are Apache and Tcl Web server.
 > 
 > 	I have had some great past experiences with TCL and would like to
 > support Scriptics efforts. Therefore, could you please point me to some
 > links which would objectively compare Tcl web server with Apache. Your own
 > opinions would be greatly appreciated.
 > 
 > Thanks,
 > Ashwini Kumar
 > 
 > 
 > _________________________________________________________________
 > Get your FREE download of MSN Explorer at http://explorer.msn.com
 > 
 > 
 > _______________________________________________
 > TclHttpd-users mailing list
 > Tcl...@li...
 > http://lists.sourceforge.net/lists/listinfo/tclhttpd-users

--	Brent Welch	<bre...@in...>
	http://www.interwoven.com

[Tclhttpd-users] Tcl Web Server vs Apache

[Ashwini K. <ash...@ho...>]

Hello,

	I am responsible for the selection of an appropriate web server for our new
project. We are looking for an embeddable web server and two of the
strongest contenders are Apache and Tcl Web server.

	I have had some great past experiences with TCL and would like to
support Scriptics efforts. Therefore, could you please point me to some
links which would objectively compare Tcl web server with Apache. Your own
opinions would be greatly appreciated.

Thanks,
Ashwini Kumar


_________________________________________________________________
Get your FREE download of MSN Explorer at http://explorer.msn.com

[Tclhttpd-users] Looking for David Maggiano

[petrus v. <pet...@si...>]

Hi,

Can someone provide me with the current mailing address of David
Maggiano, writer of "CGI Programming with Tcl".

Motorola changed for their personnel their mail addresses and all mails
I sent to David rebounced.

I made corrections and adaptations to "The Bug Tracker" that might to
interesting to a larger audience.

Piet


--
#-------With best regards,    Mit freundlichen Gruessen,    Met vriendelijke groet,  ------
# Piet Vloet
# Siemens AG Austria
# Boschstrasse 10       Phone : +43-51707-42906
# A-1190 Vienna         Fax   : +43-51707-52606
# mailto:pet...@si...                WWW:http://www.siemens.at

[Tclhttpd-users] tclhttpd or AOLserver on comp.lang.tcl

[petrus v. <pet...@si...>]

Erik Leunissen asked and  Mike Hoegeman answered.

Erik Leunissen wrote:
>
> L.S.
>
> I'm finding it difficult to decide what's the better choice for an
HTTP
> server. Thus far, I narrowed down the possibilities to either
AOLserver
> or TclHttpd (since most of the client code that I wrote, is in Tcl,
> because TclHttpd is entirely written in Tcl, and because AOLserver's
> extended functionality is based upon Tcl).

those seem like good reasons. both servers are pretty high quality
(in my experience ) if that makes you feel better about your candidates.

I use both for customers I do consulting for.
These servers are being using in production systems right now
and the customers are very happy with the results they are getting
from these servers..

>
> I'd appreciate it if someone could supply me with arguments for
> selecting either of the two. Therefore, I'll describe the intended
> functionality of the server application:
>
> - controlled access

if you mean access control on a directories etc.. both can do this.

tclhttpd uses the apache style htaccess files. you can also with a bit
of work
define you own access/authentication methods in tcl

aolserver has it's own way of controlling file access but it's complete.

you can also do your own authentication via a bit of tcl programming
on Aolserver.

> - some communication between clients and server should be encrypted

tclhttpd is capable of using the tls extension which supports SSL.
in my previous experiences it takes a bit of hair pulling to get
it all integrated together and working. new tls releases
may alleviate some of this though..

aolserver has an ns_openssl module that pretty much worked out of the
box for me
once I compiled it up.

> - content types: text and gif

both tclhttpd and aolaserver do all the normal content delivery stuff..

> - multi-threaded

both havetclhttpd and aolserver have multi threaded capabilities.

aolserver's threading capabilities are very
sophisiticated. you can for the most part just code up straightforward
tcl
in your servlets etc.. and not have to worry much about it
which is the way good threading support should work.

tclhttpd recently receieved threading capabilities but i have not used
them enough to be a good judge of it's ease of use.

> - a (pooled) connection to a mathematical engine, which generates the
> basic information from which the return content to the client is
built.
> (Not sure how to make this thread-safe).

Aolserver has a notion of pooled back-end database server
connections that work very well in conjunction with it's threading
environment. these database facilities are pluggable, dynamically loaded

modules. there is documentation on how to make these plug-ins. you
could make your mathematical engine connection pool using this
framework.
people have done this in the past for other processes that are not
database engines with good results. You'll have to do some C programming

to get that working though.

i've also made pooled connections to tclhttpd. it takes a bit of tcl
programming
to do it but it works very well. if you're not an experienced tcl
programmer
it may take you a while to get it working though..


> - running under Linux

they both run under linux

>
> Thanks in advance,

you are welcome. if you have more questions just drop me a line.

------------------------
Mike Hoegeman
Consultant -  Habanero Technologies, LLC
hm...@gt...
------------------------


--
#-------With best regards,    Mit freundlichen Gruessen,    Met vriendelijke groet,  ------
# Piet Vloet
# Siemens AG Austria
# Boschstrasse 10       Phone : +43-51707-42906
# A-1190 Vienna         Fax   : +43-51707-52606
# mailto:pet...@si...                WWW:http://www.siemens.at

Re: [Tclhttpd-users] using tclhttpd

[Brent W. <bre...@in...>]

You're basically asking for virtual server support, which is not in place.
Is there some reason you just can run a few instances of the tclhttpd process?
it isn't large - each one is only as big a single Apache process, and there
are typically 8 or more of those for one Apache instance.  If you want to
support hundreds of virtual servers, then you'll have to prototype the
changes to TclHttpd.  It probably isn't hard - but it hasn't been very
high on my list.

>>>mi...@al... said:
 > Hello!
 > 
 > I'd like to be able to bind the same server to multiple ports
 > and to register handlers (with Url_PrefixInstall) based on
 > the port number, hostname, and the prefix...
 > 
 > Any plans for adding that? Yours,
 > 
 >     -mi
 > 
 > 
 > _______________________________________________
 > TclHttpd-users mailing list
 > Tcl...@li...
 > http://lists.sourceforge.net/mailman/listinfo/tclhttpd-users

--	Brent Welch	<bre...@in...>
	http://www.interwoven.com

[Tclhttpd-users] using tclhttpd

[<mi...@al...>]

Hello!

I'd like to be able to bind the same server to multiple ports
and to register handlers (with Url_PrefixInstall) based on
the port number, hostname, and the prefix...

Any plans for adding that? Yours,

    -mi

[Tclhttpd-users] cgiexec arguments

[Jeff M. <je...@in...>]

Hi,

I  have done something completely stupid. I am doing some cgi (using my copied
version of CgiExec) and I see that if I have arguments starting with the special
exec characters
(e.g., <, >, |) the open call treats those  like pipe redirects, etc. e.g.:

set arglist [list -subject "<some subject" -body "|"]
return [open "|[list $Cgi(tclsh) $script] $arglist" r+]

Is there any way around this?
(short of putting a space before any special characters in the arg list like:
foreach a $arglist {
 regsub "^(\[<>2|])" $a { \1} a
 lappend l $a
    }
)

Thanks,
Jeff

RE: [Tclhttpd-users] 3.2.1 crashes on first access with threads enabled.

[David L. <wh...@oz...>]

Hey Brent;

Turns out I had thread 2.0 in the path. I see that Thread 2.2 is in the
distro - i'll build that and see if it works any better (hopefully).

If tclhttpd 3.2.1 requres Thread 2.2 shouldn't it insist on that version?

Regards,

Dave LeBlanc

-----Original Message-----
From: bw...@in... [mailto:bw...@in...]On Behalf Of
Brent Welch
Sent: Monday, December 04, 2000 10:56 AM
To: David LeBlanc
Cc: tcl...@li...
Subject: Re: [Tclhttpd-users] 3.2.1 crashes on first access with threads
enabled.



>>>"David LeBlanc" said:
 > Platform: NT 4.0sp6 workstation
 >
 > tcl 8.3.2 tk 8.3.2
 >
 > tclhttpd 3.2.1
 >
 > I built tcl/tk 8.3.2 from the tclhttpd distro and also installed tcllib
0.8.
 >
 > With a thread count of 0 in the httpd.rc file, it comes up, one can
access
 > pages, but it crashes (access violation in Wish) fairly readily  but not
 > consistanly on the same access (for example "simple template" crashed
once,
 > but not when retried after restarting tclhttpd). With threads set to 8,
it
 > will crash on first access by a browser with an access violation,
although
 > the requested (home) page is displayed by the browser.
 >
 > If i've enabled threads in the tcl/tk build (I did!), do I also have to
 > build the threads package? If so, where should it be installed?
 >
 > All input appreciated!

Yes - you need the thread extension.  I'm suprised it doesn't complain
during startup that the "package require Thread" doesn't work.
Configure and build the thread extension with the same
prefix, exec-prefix as your threaded Tcl build, and those Tcl
shells should find the thread package after you "make install" it.

--	Brent Welch	<bre...@in...>
	http://www.interwoven.com

Re: [Tclhttpd-users] 3.2.1 crashes on first access with threads enabled.

[Brent W. <bre...@in...>]

>>>"David LeBlanc" said:
 > Platform: NT 4.0sp6 workstation
 > 
 > tcl 8.3.2 tk 8.3.2
 > 
 > tclhttpd 3.2.1
 > 
 > I built tcl/tk 8.3.2 from the tclhttpd distro and also installed tcllib 0.8.
 > 
 > With a thread count of 0 in the httpd.rc file, it comes up, one can access
 > pages, but it crashes (access violation in Wish) fairly readily  but not
 > consistanly on the same access (for example "simple template" crashed once,
 > but not when retried after restarting tclhttpd). With threads set to 8, it
 > will crash on first access by a browser with an access violation, although
 > the requested (home) page is displayed by the browser.
 > 
 > If i've enabled threads in the tcl/tk build (I did!), do I also have to
 > build the threads package? If so, where should it be installed?
 > 
 > All input appreciated!

Yes - you need the thread extension.  I'm suprised it doesn't complain
during startup that the "package require Thread" doesn't work.
Configure and build the thread extension with the same
prefix, exec-prefix as your threaded Tcl build, and those Tcl
shells should find the thread package after you "make install" it.

--	Brent Welch	<bre...@in...>
	http://www.interwoven.com

Re: [Tclhttpd-users] Q: Using TclHTTPD as a proxy server?

[Brent W. <bre...@in...>]

The latest version of TclHttpd contains these bits of code to
support the proxy case, but I haven't actually used it yet:
This is in HttpdRead:

Here is where it is looking at the GET/POST requests.
If you are a proxy, you see

GET http://server:port/url HTTP/1.0

If you are not a proxy, you just get

GET /url HTTP/1.0

                # Strip leading http://server and look for the proxy case.

                if {[regexp {^https?://([^/:]+)(:([0-9]+))?(.*)$} $data(url) \
                        x xserv y xport urlstub]} {
                    set myname [Httpd_Name $sock]
                    set myport [Httpd_Port $sock]
                    if {([string compare \
                            [string tolower $xserv] \
                            [string tolower $myname]] != 0) ||
                            ($myport != $xport)} {
                        set data(host) $xserv
                        set data(port) $xport
                    }
                    # Strip it out if it is for us (i.e., redundant)
                    # This makes it easier for doc handlers to
                    # look at the "url"
                    set data(url) $urlstub
                }

Then later, when you have the request all ready, it does this:

            # Do a different dispatch for proxies.  By default, no proxy.

            if {[info exist data(host)]} {
                if {[catch {
                    Proxy_Dispatch $sock
                } err]} {
                    Httpd_Error $sock 400 "No proxy support\n$err"
                }
            } else {
                # Dispatch to the URL implementation.

                # As a service for domains that loose track of their
                # context (e.g., .tml pages) we save the socket in a global.
                # If a domain implementation would block and re-enter the
                # event loop, it must use Httpd_Suspend to clear this state,
                # and use Httpd_Resume later to restore it.

                set Httpd(currentSocket) $sock
                CountStart serviceTime $sock
                Url_Dispatch $sock
            }

There is no "Proxy_Dispatch" in the source code - you'll have
to supply your own.  Let us know how it goes!

--	Brent Welch	<bre...@in...>
	http://www.interwoven.com

[Tclhttpd-users] 3.2.1 crashes on first access with threads enabled.

[David L. <wh...@oz...>]

Platform: NT 4.0sp6 workstation

tcl 8.3.2 tk 8.3.2

tclhttpd 3.2.1

I built tcl/tk 8.3.2 from the tclhttpd distro and also installed tcllib 0.8.

With a thread count of 0 in the httpd.rc file, it comes up, one can access
pages, but it crashes (access violation in Wish) fairly readily  but not
consistanly on the same access (for example "simple template" crashed once,
but not when retried after restarting tclhttpd). With threads set to 8, it
will crash on first access by a browser with an access violation, although
the requested (home) page is displayed by the browser.

If i've enabled threads in the tcl/tk build (I did!), do I also have to
build the threads package? If so, where should it be installed?

All input appreciated!

Dave LeBlanc

RE: [Tclhttpd-users] Q: Using TclHTTPD as a proxy server?

[David L. <wh...@oz...>]

Jacob;
Maybe i'm not clear on what a proxy server is then. My notion is that it
receives requests and "gates" them according to some criteria to the actual
server handling requests.

I didn't know that tclhttpd could serve multiple ports simultaneously!

Dave LeBlanc

-----Original Message-----
From: Jacob Levy [mailto:jy...@be...]
Sent: Sunday, December 03, 2000 8:19 AM
To: David LeBlanc
Cc: tcl...@li...
Subject: Re: [Tclhttpd-users] Q: Using TclHTTPD as a proxy server?


David

Thanks!

I was thinking of something simpler. Since there's probably a way to start
the
server as a proxy on a certain port, I'd start it on (for example) port 3333
as
a proxy and as usual on port 8015 as a server. That way I'd have two copies
of
the server running within one process. AFAIK it's already possible to run
TclHTTPD as a server serving multiple ports (e.g. 8015 and 8080) at the same
time, so this would be a small change.

Comments?

David LeBlanc wrote:

> This might not be exactly a cookbook, but here it is fwiw.
>
> The use of tclhttpd as a proxy server is a recurring question on the list.
>
> Dave LeBlanc
> ****************************************************************
>
> Subject: Proxy Server Using TCL (Please disregard previous post, forgot
> non-binary group! =-)
> From: lu...@pi...
> Date: 1999/05/16
> Newsgroups: comp.lang.tcl
> I am assisting a good friend with this final project, which he needs
> to graduate and I hope someone here can lend a little help if
> possible. Included in this message below is a proxy server written in
> TCL,
> saved in text format. The question he's grappling with is:
>
> Suppose your proxy were ALSO a server.  At what point or points in the
> code (indicate the exact routine and line) would you branch to server
> functionality?  Why?
>
> I'm not familiar with TCL(neither is he) and he needs it by Tuesday in
> order to graduate. =-( Hate to be a bother or anything, but if anyone
> can help, please email me a response to:
>
> lu...@pi...
>
> If anything, I'm hoping this code will assist others with similar
> projects, as sometimes stuff like this is tough to come by. =-)
>
> Thanks...
>
> #!/bin/sh
> # the next line restarts using tclsh \
> exec tclsh "$0" $@
>
> #
> # $Id: http_proxy.tcl,v 4.4 1997/01/30 00:01:19 dl Exp $
> #
> # An Privacy enhanced http proxy,
> # initially based on my geturl2 raw WWW client and my tclhttpd
> # (suitable for anonymous web access)
> #
> # Sample usage:
> #    nohup http_proxy listeningport [nbrhops prox1 ... proxyn] >
> /dev/null &
> # if nbrhops and proxyI are provided,
> # the proxy will generate a random route of nbrhops hops,
> # amongst proxy 1...N   (nbrhops must be >= N)
> #
> # You can see/modify the parameters using your web browser, accessing
> #   http://localhost:listeningport/admin
> # To do this you shall define an APROXYPASS environement variable,
> equal
> # to the md5 digest/checksum of your password, for access to
> # the proxy admin page (use 'md5sum "pass"' proc to get the value)
> # For instance, to use the string 'passwd' as password, use :
> # setenv APROXYPASS 76a2173be6393254e72ffa4d6df1030a
> #
> # NB: POST support and admin parameters modification is not yet
> finished.
> #
> # You need a Binary tcl shell : tcl7.5 or later + tclbin +(and
> optionally tclX)
> # interp to use it
> # ( tcl7.5 needed to listen to tcp port and clock, tclX for
> lassign,etc
> #  and tclbin for real binary IOs, md5 checksum/digest interface,...)
> #
> # To build this shell you need the tclbin distrib
> # http://www.box.eu.org/~dl/tclbin.html and ftp://ftp.box.eu.org/tcl/
> # C source files compressed tar file : tclbin-*.tgz  (currently v1.2)
> #
> # THIS IS A BETA RELEASE - PLEASE DON'T DISSEMINATE
> #
> # (c)1995 by Laurent Demailly - dl...@ww...
> #            http://www.box.eu.org/~dl/
> #
> # Latest version shall always be available from
> # http://www.box.eu.org/~dl/wwwtools.html
> #
> # (please send me feed back, comments, and tell me if you made
> changes,...)
> #
> # ``Artistic'' license see LICENSE - Author: Laurent Demailly
> #
> # This program is free software; you can redistribute it and/or modify
> # it under the terms and CONDITIONS of the included LICENSE
> #
> # If you don't have the LICENSE or need to clarify anything please
> # contact the author
> #
> # This program is distributed in the hope that it will be useful,
> # but WITHOUT ANY WARRANTY; without even the implied warranty of
> # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
> #
> # $Log: http_proxy.tcl,v $
> # Revision 4.4  1997/01/30 00:01:19  dl
> # updated urls and emails. fix in 64ToStr.
> #
> # Revision 4.3  1996/05/08  13:41:04  dl
> # fixed huge bug of unreturned buffer because notreadylock() was not
> unset
> #
> # Revision 4.2  1996/05/02  22:39:03  dl
> # missing -translation binary was causing garbage on binary files
> #
> # Revision 4.1  1996/05/02  21:58:44  dl
> # Tcl(7.5) + tclbin only version (and optional tclX)
> # no more tcldp.
> # no 100% finished yet [the write blocking must be reimplemented
> nicely]
> #
> # Revision 3.8  1996/04/22  18:54:47  dl
> # added a lock for client waiting / close while waiting case
> # typo/bugfix peer was not declared global in main handler
> #
> # Revision 3.7  1996/04/09  15:52:04  dl
> # Don't send more bytes than "Content-Length" in request, even if
> client does
> #
> # Revision 3.6  1996/04/09  15:32:01  dl
> # added `small' POST requets support ! (which implied a binary read of
> # headers/client too...)
> # optional passing of Authorization* headers
> #
> # [old logs deleted for space sake]
>
> # If you didn't "make install"
> # copy libdlbin.sl to /usr/local/lib/tcl7.5
> # and run
> # echo 'pkg_mkIndex /usr/local/lib/tcl7.5 *[info sharedlibextension]'|
> tclsh7.5
> # or
> #lappend auto_path .
> # to test it in current directory
>
> package require Bin;
> package require Mdfive;
>
> if [catch {package require Tclx} res] {
>   puts "Running without tclX ($res) (using compat in tcl lib, a bit
> slower)";
> # Some minimal TclX replacements...
> proc getclock {} {clock seconds}
> proc lempty {lst} {regexp "\[ \t\n\]" $lst}
>
> proc fmtclock {clockval {format {}} {zone {}}} {
>     lappend cmd clock format $clockval
>     if ![lempty $format] {
>         lappend cmd -format $format
>     }
>     if ![lempty $zone] {
>         lappend cmd -gmt 1
>     }
>     return [eval $cmd]
> }
> # simple one (no step/no continue...)
> proc loop {var start end body} {
>   upvar $var v;
>   for {set v $start} {$v<$end} {incr v} {
>     uplevel $body;
>   }
> }
> proc lassign {list args} {
>   set i 0;
>   foreach vname $args {
>     uplevel [list set $vname [lindex $list $i]];
>     incr i;
>   }
>   lrange $list $i end
> }
> proc clength {str} {string length $str}
> proc cequal {s1 s2} {expr [string compare $s1 $s2]==0}
> # simple, we don't do "end"
> proc crange {str first last} {string range $str [expr $first] [expr
> $last]}
> # tcl-usage' faq random :
> proc random {args} {
>   global RNG_seed;
>
>   set max 259200;
>   set argcnt [llength $args];
>   if { $argcnt < 1 || $argcnt > 2 } {
>     error "wrong # args: random limit | seed ?seedval?"
>   }
>   if ![string compare [lindex $args 0] seed] {
>     if { $argcnt == 2 } {
>       set RNG_seed [lindex $args 1]
>     } else {
>       set RNG_seed [clock clicks] ; # poor...
>     }
>     return;
>   }
>   if ![info exists RNG_seed] {
>     set RNG_seed [clock clicks] ; # poor...
>   }
>   set RNG_seed [expr ($RNG_seed*7141+54773) % $max]
>   return [expr int(double($RNG_seed)*[lindex $args 0]/$max)]
> }
> proc lvarpop {var} {
>   upvar $var v;
>   set r [lindex $v 0];
>   set v [lrange $v 1 end];
>   return $r;
> }
> }
>
> #
> # ---------- start of CONFIGURABLE section ----------
>
> # max simultaneous proxy connections allowed
> set maxconn 4
> # absolute maximum (each proxy requires 2 connections)
> set absmaxconn [expr 2*$maxconn];
> # timeout in seconds for getting a query  (in milli-seconds)
> set qtimeout 20000;
> # timeout for the whole connect  (600000 = 10 mins)
> set stimeout 120000 ; # two minutes is enough (we want to be fast)
> # buffer size for one connection
> set bufsz 32768 ;#16384; #8192
>
> # set denied(aaa.bbb.ccc.ddd) 1;
>
> # proc that is called for each connecting IP and shall return 0 for ok
> # and 1 for denied.
> proc access_forbid {host} {
>   global denied;
> # like this, unless host is found in the above 'denied' array, access
> granted
> # but this proc can be complexified at will to support any kind of
> access ctrl
>   info exists denied($host)
> }
>
> # ---------- end of configurable section ----------
>
> # determine this server host and domain name :
>
> # Note: on some OS/configs hostname is directly the fqhn
> # (for me, not)
> set hostname [lindex [split [exec hostname] .] 0];
> # the running host full qualified name (host.domain name)
> set fqhn [exec nslookup $hostname]
> regexp "Name: +(\[^\n\]+)\n" $fqhn all fqhn;
> # domain name alone
> regexp {^([^\.]+)\.(.+)$} $fqhn all hn domain;
> # (btw hn should be == hostname)
>
> # record starting time
> set dateup [fmtclock [getclock] "%d %h %Y %H:%M %Z" GMT];
>
> #
> # Buffer setup
> #
>
> # total buffer size
> set bigbufsz [expr $bufsz*$maxconn];
>
> bin_new bigbuf buffer $bigbufsz;
> set freebuflst {};
>
> loop i 0 $maxconn {
>   # split the big buf in smaller shunks
>   bin_new buf${i} buffer $bufsz bigbuf $i*$bufsz;
>   bin_new buf${i}in  buffer $bufsz buf${i};
>   bin_new buf${i}out buffer 0      buf${i};
>   lappend freebuflst $i;
> }
>
> proc getfreebuf {} {
>   global freebuflst;
>   set res [lvarpop freebuflst]
>   if {[cequal $res ""]} {error "no more bufs!"}
>   return $res
> }
>
> proc givebackbuf {i} {
>   global freebuflst;
>   lappend freebuflst $i;
>   global buf${i}in buf${i}out;
>   bin_move -absolute buf${i}out 0;
>   bin_move -absolute buf${i}in  0;
>   global bufsz;
>   bin_resize buf${i}in $bufsz;
> }
>
> # by default, only one routing
> set autoroute {}
> set nbrhops 0;
> # by default, post is not allowed
> #set allowpost 0;
> set allowpost 1;
>
> # allow authorization* headers ?
> set allowauth 1;
>
> # rcs kewords extraction
> regexp {[.0-9]+} {$Revision: 4.4 $} version
>
> # Proxy List keyword in http header:
> set plistkeyw "ProxyControl";
> # Protocol Version
> set plistvers 1
>
> # debug ?
> set debug 2
> if {[info exists env(DEBUG)]} {
>   set debug $env(DEBUG);
>   if {[catch {expr $debug>0}]} {set debug 0}
> }
>
> #
> # proxy transfer handler, called when there is something to read
> # on the socket server socket (copy it to the client):
> #
> proc trans_handler {cliconn mode servconn {recurs 0}} {
>   global trkbytes debug;
> #  puts "called trans_handler $cliconn $servconn $recurs";
>   global bufid bufsz;
>   set id $bufid($servconn);
>   upvar buf${id}in  bufin ;
>   upvar buf${id}out bufout ;
>
>   if {[catch {bin_sizeof bufin} sz1]} {
>     puts "hmmm error '$sz1' for id=$id, on
> $cliconn,$servconn,$recurs";
>     do_close $cliconn "error bufin!";
>   }
>   if {$sz1!=0} {
>     if {[catch {set n [bin_read $servconn bufin]} res]} {
>       set n 0;
> if {$debug>=1} {
>       puts "th $cliconn $servconn : got read error : $res";
> }
>     }
> if {$debug>=3} {
>     puts "th $cliconn $servconn : read $n/$sz1 bytes";
> }
>   } else {
>     set n 0;
> if {$debug>=3} {
>     puts "th $cliconn $servconn : read buffer full, no read";
> }
>   }
>   if {$n==0} {
>     if {[bin_sizeof bufout]==0} {
>       do_close $cliconn "transmit done (now $trkbytes kb)";
>       return;
>     }
>   } else {
>     bin_resize bufin $sz1-$n;
>     set szi [bin_move bufin $n 1];
> # we got a bug in the resize below... (should be fixed by the
> notreadylock..)
> #puts "trh c=$cliconn m=$mode s=$servconn r=$recurs
> n=$n,sz1=$sz1,szi=$szi";
>     if {[catch {bin_resize bufout $szi-[bin_move bufout 0]} msg]} {
>       puts "error resize bufout: [bin_info bufout]";
>       tkerror $msg;
>     }
>   }
>
>   if {$recurs} {return $n}
>
> #  if {[lempty [lindex [select {} $cliconn {} .2] 1]]}
> #  global writable
> #  set writable($cliconn) 0
> #  fileevent $cliconn w "set writable($cliconn) 1";
> #  puts "before vwait writable($cliconn)";
> #  fileevent $servconn r {};
> #  vwait writable($cliconn);
> #  fileevent $servconn r "trans_handler $cliconn r $servconn";
> #  puts "after  vwait writable($cliconn)";
>
>   if {0} { # with tcl7.5 we can always write... (!)
>     # not ready to write...
> if {$debug>=3} {
>     puts "th $cliconn $servconn : client not ready 1 for writing";
> }
>     fileevent $servconn r {};
>     global notreadylock;
>     set notreadylock($servconn) 1;
>     update
>     if {!$notreadylock($servconn)} {
>       # socket have been closed in update, finish do_close' job
>       givebackbuf $bufid($servconn);
>       unset bufid($servconn);
>       unset notreadylock($servconn);
>       return ;
>     }
>     while {[lempty [lindex [select {} $cliconn {} .2] 1]]} {
> if {$debug>=2} {
>       puts "th $cliconn $servconn : client not ready n for writing";
> }
>       update;
>       if {!$notreadylock($servconn)} {
>         # socket have been closed in update, finish do_close' job
>         givebackbuf $bufid($servconn);
>         unset bufid($servconn);
>         unset notreadylock($servconn);
>         return ;
>       }
>       if {[uplevel #0 trans_handler $cliconn $mode $servconn 1]==0} {
>         loop i 0 4 {
>           after 250
>           update
>           if {!$notreadylock($servconn)} {
>             # socket have been closed in update, finish do_close' job
>             givebackbuf $bufid($servconn);
>             unset bufid($servconn);
>             unset notreadylock($servconn);
>             return ;
>           }
>         }
>       }
>     }
>     unset notreadylock($servconn);
>     fileevent $servconn r "trans_handler $cliconn r $servconn";
>   }
>
>   set sz2 [bin_sizeof bufout];
>   if {[catch {set p [bin_write - $cliconn bufout]} res]} {
>     set p 0;
> if {$debug>=1} {
>     puts "th $cliconn $servconn : got a write error : $res";
> }
>   }
> if {$debug>=3} {
>   puts "th $cliconn $servconn : wrote $p/$sz2";
> }
>   bin_resize bufout $sz2-$p;
>   if {$p==$sz2} {
> # everything was read
> #    puts "reset";
>     bin_move -absolute bufout 0;
>     bin_move -absolute bufin  0;
>     bin_resize bufin $bufsz;
>   } else {
>     bin_move bufout $p 1;
>   }
> #  catch {flush $cliconn}
>   set trkbytes [expr $trkbytes+$n/1024.];
> #  puts "th $cliconn $servconn : transmitted $n bytes -> $trkbytes";
> }
>
> #
> # usage / startup error
> #
> proc usage {msg} {
> puts stderr "Error $msg";
> puts stderr "Usage: [info script] port \[nbrhops proxy1 ...proxyN\]";
> exit 1;
> }
>
> if {$argc==0} {usage "no port given!"};
>
> lassign $argv port;
> if {$argc==2} {usage "nbrhops given but no proxies!"};
> if {$argc>2} {
>   set nbrhops [lindex $argv 1];
>   set autoroute [lrange $argv 2 $argc];
>   set lg [llength $autoroute];
>   if {[catch {expr $nbrhops>$lg} res]} {usage "nbrhops is not a
> number!"};
>   if {$res} {usage "nbrhops > number of proxies given!"};
> };
>
> # listen on port
> set srv [socket -server newconn $port]
> # init counters and stat:
> set nbrconn 0;
> set count 0;
> set pcount 0;
> set trkbytes 0.0;
>
> # connect handler:
> puts stderr "listening on host $fqhn ($hostname,$domain) on port
> $port";
> puts stderr "nbrhops=$nbrhops, autoroute=($autoroute)";
>
> # accept connects:
> proc newconn {socket host port} {
>   global count absmaxconn nbrconn qtimeout time queue ql debug;
>   set ts [getclock];
> if {$debug>=1} {
>   puts "C $ts ($nbrconn,$count) $host -> $socket";
> }
>   incr count;
>   if {[access_forbid $host]} {
> if {$debug>=0} {
>     puts "denied $host";
> }
>     catch {close $socket};
>     return
>   }
>   incr nbrconn;
> #  dp_socketOption $socket sendBuffer 16384;
>   fconfigure $socket -blocking no -translation binary;
> #  dp_socketOption $socket keepalive yes;
>   if {$nbrconn>$absmaxconn} {
>      toobusy $socket "Too many connections ($nbrconn), reload in few
> moments"
>      return;
>   };
>   set time($socket) $ts;
>   set queue($socket) {};
>   set ql($socket) 0;
>   fileevent $socket r "handler $host r $socket";
>   after $qtimeout "qtimeout $socket $ts"
> }
>
> proc qtimeout {file ts} {
>   global time;
>   #puts "called timeout $file $ts";
>   if {[info exists time($file)]} {
>     #puts "times($file)=$times($file)";
>     if {$time($file)==$ts} {
>       serror $file "Received no valid query" 408 "Request Timeout";
>     }
>   }
> }
>
> proc stimeout {file ts} {
>   global time;
>   #puts "called timeout $file $ts";
>   if {[info exists time($file)]} {
>     #puts "times($file)=$times($file)";
>     if {$time($file)==$ts} {
>       do_close $file "session too long";
>     }
>   }
> }
>
> # read buffer
> bin_new buffer buffer 16384;
> bin_new bufptr buffer 0 buffer;
> bin_new bufrst buffer 0 buffer;
>
> # Main connection handler
> # determines what is requested and what to call for answer
> #
> proc handler {host mode file} {
>   global peer time queue ql plistkeyw plistvers debug \
>      fqhn hostname domain port nbrhops autoroute allowpost allowauth;
>   set what {};
>   global buffer bufptr bufrst;
>   if {[catch {bin_read $file buffer} lg]} {
>     do_close $file "read error '$lg'";
>     return;
>   }
> #  puts "called handler $file : read '$what'";
>   if {$lg==0} {do_close $file "eof"; return}
>   if {[info exists peer($file)]} {return}; #ignore what client says
> after conn
>   bin_resize bufptr $lg;
>   set what $bufptr(_str_);
>   regsub -all {\\.} $what {\\} what; # so [clength $what] is r
>   # (side effect: if there are '\0' in headers (which is illegal),
>   # they'll appear as '\')
>   append queue($file) $what;
>   # header is fully here ? (if not we just wait)
>   if {![regexp -indices "\r?\n\r?\n" $queue($file) idx]} {
>     if {($ql($file)+$lg)>1024} {
>       serror $file "" 400 "Query too long"
>     } else {
>       incr ql($file) $lg;
>     }
>     return;
>   }
>   # cool, we found the header separation
>   lassign $idx p1 p2;
>   set rest [expr $lg-($p2+1-$ql($file))];
>   bin_resize bufrst $rest;
>   if {$rest!=0} {
>     bin_move -absolute bufrst $lg-$rest 1;
> if {$debug>=4} {
>   puts "remaining $rest bytes! ($bufrst(_str_))";
> }
>   }
>   set what [crange $queue($file) 0 $p1-1];
>   regsub -all "\r" $what {} what;
>   if {![regexp \
> "^(\[^ \n\]+) (\[^ \n\]+) HTTP/1.0(\n(.+\n)?($plistkeyw: V(\[0-9\]+)
> ?(\[^\n\]*))\n)?"\
>    $what gall method url r1 r2 apline apvers aplist]} {
>     # wrong command... problem
>     serror $file \
>            "Format unrecognized:\n<pre>\n[txt2html $what]</pre>" \
>            400 "Bad Request";
>     return;
>   }
>   if {![regexp {^(GET|HEAD|POST)$} $method]} {
>     # not implemented method
>     serror $file \
>       "Sorry, the method <strong>$method</strong> is not
> implemented.\n\
>       <p>Your query was\n<pre>\n[txt2html $what]</pre>" \
>       501 "Not Implemented ($method)";
>     return;
>   }
>   # if a local url is requested, skip proxying it :
>   if {[regsub -nocase
> "^http://($fqhn|$hostname|localhost(\.$domain)?|127\.0\.0\.1):$port/"
> $url / url]} {
> if {$debug>=3} {
>     puts "url found to be local ($url)"
> }
>   }
>   # Do we want full thing or headers only?
>   set getflag [expr ![cequal $method "HEAD"]];
>   set postflag [cequal $method "POST"];
>   set moreheaders {};
>   set contentLG 0;
>   if {$postflag} {
>     # get and check content-length
>     set contentLG 0;
>     regexp -nocase {Content-length: *([0-9]+)} $what all contentLG;
>     if {$contentLG>$rest} {
>       serror $file "I can't handle this post request because\
> \nYou have to send $contentLG bytes and I've read only $rest bytes..."
> \
>       500 "Can't handle this Post $rest/$contentLG";
>       return;
>     }
>     if {$contentLG>0} {bin_resize bufrst $contentLG}
>     # extract/save all Content-* headers
>     set all $what;
>     while {[regexp -nocase "\n(Content-\[^\n\]+)(.*)$" $all a ct all]}
> {lappend moreheaders $ct}
>   }
>   if {$allowauth} {
>     set all $what;
>     while {[regexp -nocase "\n(Authorization\[^\n\]+)(.*)$" $all a ct
> all]} {lappend moreheaders $ct}
>   }
>   if {$debug>5} {puts "content=($moreheaders), contentLG=$contentLG"}
>   switch -regexp -- $url {
>       {^/admin}   {
>         if {[regexp -nocase "\nAuthorization: +Basic +(\[^\n\]+)" \
>                     $what all auth]} {
>           set user "";
>           set pass "";
>           regexp {^([^:]+):(.+)$} [64ToStr $auth] all user pass;
>           if {[admincheck $host $user $pass]} {
>             serror $file "Bad host/user/passwd" 401 \
>               "Unauthorized" "WWW-Authenticate: Basic
> realm=\"admin\"\n";
>           } else {
>             admin $file $getflag $host $user $pass;
>           }
>         } else {
>           serror $file "You need an authorisation capable browser to
> access" \
>             401 "Unauthorized" "WWW-Authenticate: Basic
> realm=\"admin\"\n";
>         }
>       }
>       {^/source} {sendsource     $file $getflag}
>       {^/}       {sendserverinfo $file $getflag [txt2html
> $queue($file)]}
>       default {
>         if {$postflag && !$allowpost} {
>           serror $file "POST is disabled.\n\
>           <p>Your query was\n<pre>\n[txt2html $queue($file)]</pre>" \
>           403 "Forbidden";
>           return;
>         }
>         # real proxy job:
>         # parse the url :
>         if {![regexp {^http://([^/:]+)(:([0-9]+))?(/[^#]*)?(#.*)?$}
> $url \
>                      all dhost p dport what key]} {
>             # for instance port must be numerical
> if {$debug>=2} {
>         puts "invalid url='$url' ($queue($file))";
> }
>             serror $file "<pre>$url</pre>" 400 "Invalid Proxy URL";
>             return;
>           }
>         if {[cequal $dport ""]} {set dport 80}
>         if {[cequal $what ""]} {set what "/"}
> # port checking #1/2 :
>         if {$dport<1024 && $dport!=80} {serror $file "Illegal dest.
> port $dport" 403 "Forbidden"; return}
>         set apflag [expr [cequal $apline ""]==0];
> if {$debug>=1} {
>         puts "$file -> proxying $method http://$dhost:$dport$what
> ($apline)";
> }
>         if {$apflag} {
>           if {([catch {expr $apvers!=$plistvers} res] || $res)} {
>            serror $file "<pre>$apline</pre>" 500 "Invalid Proxy Ctrl
> Version";
>            return;
>           }
>           if {[catch {llength $aplist} lg]} {
>            serror $file "<pre>$aplist</pre>" 400 "Invalid Proxy List";
>            return;
>           }
>         } else {
>           if {$nbrhops!=0} {
>             # generate a random proxy route, choosen in autoroute
>             set aplist [random_path $nbrhops $autoroute [llength
> $autoroute]];
>             set lg [llength $aplist];
> if {$debug>=1} {
>             puts "generated random path ($aplist)";
> }
>           } else {set lg 0}
>         }
>         if {$lg>=1} {
>           set thisproxy [lindex $aplist 0];
>           set restproxy [lrange $aplist 1 $lg];
>           if {![regexp {^(.+):([0-9]+)$} $thisproxy all phost pport]}
> {
>             serror $file "<pre>$thisproxy</pre>" 400 "Invalid Next
> Proxy Entry";
>             return;
>           }
>           lappend moreheaders "$plistkeyw: V$plistvers $restproxy";
> # port checking #2/2 :
>           if {$pport<1024 && $pport!=80} {serror $file "Illegal proxy
> port $pport" 403 "Forbidden"; return}
>           do_query $file $method $phost $pport \
>              "http://$dhost:$dport$what" [join $moreheaders \r\n]
> $contentLG;
>         } else {
>           lappend moreheaders $apline;
>           do_query $file $method $dhost $dport $what [join
> $moreheaders \r\n] $contentLG;
>         }
>       }
>     }
> }
>
> proc random_path {n list lg} {
>  set idx [random $lg]
>  if {$n>1} {
>    incr n -1;
>    incr lg -1;
>    return "[lindex $list $idx] [random_path $n [lreplace $list $idx
> $idx] $lg]"
>  } else {
>    return "[lindex $list $idx]"
>  }
> }
>
> proc txt2html {str} {
> regsub -all "&" $str {\&amp;} str;
> regsub -all "<" $str {\&lt;} str;
> regsub -all ">" $str {\&gt;} str;
> regsub -all \" $str {\&quot;} str;
> return $str;
> }
>
> proc toobusy {file msg} {
>   serror $file "$msg\n<p>Try to <b>reload</b> in a moment" 503
> "Service Overloaded" \
>              "Retry-After: 15\n";
> }
>
> proc serror {file msg {id 500} {title "Error"} {more ""}} {
>   global version fqhn port;
>   catch {
>     puts $file "HTTP/1.0 $id $title
> Server: tclProxy/dl$version
> Content-Type: text/html
> $more
> <HEAD><TITLE>$title</TITLE>
> <link rev=\"made\" href=\"mailto:ld...@ma...\">
> </HEAD>
> <BODY>
> <H1>$title</H1>
> $msg
> <HR>
> <ADDRESS>
> <A HREF=\"http://$fqhn:$port\">
> Anonymous proxy httpd</a> v$version server in tcl, by
> <A HREF=\"http://www.box.eu.org/~dl/\">dl</A>
> </ADDRESS>
> </BODY>"
>   }
>   do_close $file "error ($id $title)";
> }
>
> proc htmlblah {file getflag title msg} {
>   global version;
>    set sendstr "<HEAD><TITLE>$title</TITLE>
> <link rev=\"made\" href=\"mailto:ld...@ma...\">
> </HEAD>
> <BODY>
> <H1>$title</H1>
> $msg
> <HR>
> <ADDRESS>
> <A HREF=\"http://www.box.eu.org/~dl/wwwtools.html\">
> Anonymous proxy httpd</a> v$version server in tcl,
> <A HREF=\"http://www.box.eu.org/~dl/disclaimer.html\">&copy;</A>
>  by
> <A HREF=\"http://www.box.eu.org/~dl/\">dl</A>
> </ADDRESS>
> </BODY>
> "
>   set sl  [clength $sendstr];
>   set chk [md5sum  $sendstr];
>   catch {
>     puts $file "HTTP/1.0 200 Document follows
> Server: tclProxy/dl$version
> Content-Type: text/html
> Content-Length: $sl
> Content-Digest: MD5=$chk
> "
>   flush $file;
>   if $getflag {puts -nonewline $file $sendstr}
>   }
>   do_close $file "htmlblah $getflag ($title)";
> }
>
> proc sendserverinfo {file getflag what} {
>   global nbrconn absmaxconn count pcount dateup trkbytes fqhn port
> freebuflst;
>         htmlblah $file $getflag "Anonymous Proxy HTTP Server" "
> Welcome on this experimental WWW proxy server, feel free to use it
> (but not
> abuse it, <b>please</b>), source is
> <a href=\"/source\">here</a> and latest version and informations are
> on
> <a href=\"http://www.box.eu.org/~dl/wwwtools.html\">
> http://www.box.eu.org/~dl/wwwtools.html</a>.<p>
> Use <tt>setenv http_proxy http://$fqhn:$port/</tt> to use it, or
> better, run
> a local copy and join the privacy http proxy network.
> <p>
> Access restricted <a href=\"http://localhost:$port/admin\">proxy
> admin</a>.
> <p>
> Look at the amount of information <em>your</em> browser is sending
> (and this
> proxy is throwing away) :<br>
> See for instance the <a href=\"refered\">Referer:</a> that might
> contain
> very personal informations (back links).
> (Not all browsers put a Referer field, though)
> <pre>
> $what</pre>
> <p>
> Currently: $nbrconn/$absmaxconn open connections,<br>
> Free buffers: $freebuflst<br>
> Served a total of $count requests since $dateup<br>
> Proxy requests: $pcount, transmitted [format %.1f $trkbytes] kbytes"
> }
> #
> # Closing proc
> #
> proc do_close {file msg} {
>   global nbrconn time queue ql peer bufid debug;
> if {$debug>=1} {
>   puts "closing $file ($msg)"; flush stdout;
> }
>   catch {fileevent $file r {} }
>   catch {unset time($file)}
>   catch {unset queue($file)}
>   catch {unset ql($file)}
>   global notreadylock;
>   if {[info exists bufid($file)]} {
>     if {[info exists notreadylock($file)]} {
>       set notreadylock($file) 0; # raise flag so it can given back
> later...
>     } else {
>       givebackbuf $bufid($file);
>       unset bufid($file);
>     }
>   }
>   if {[info exists peer($file)]} {
>     set mypeer $peer($file);
>     unset peer($file);
>     if {[info exists time($mypeer)]} {do_close $mypeer "peer $msg"}
>   }
> #  catch {flush $file}
>   catch {close $file}
>   incr nbrconn -1;
> }
>
> proc do_query {file method host port what apline contentLG} {
> global peer bufid time stimeout version count pcount conn nbrconn
> debug;
> # connect to the host
> if {[catch {set socket [socket $host $port]} msg]} {
>   puts stderr "connect on $host port $port : $msg";
>   serror $file "Connect error on $host port $port : $msg" 404 "Not
> found";
>   return;
> }
> # dp_filehandler $file; #ignore what client migh say now
> # (in fact not, lets detect close)
>
> fconfigure $socket -blocking no -translation binary;
> #dp_socketOption $socket keepalive yes;
> set ts [getclock]
> if {$debug>=1} {
> puts "S $ts ($nbrconn,$count) $host:$port -> $socket";
> }
> set time($socket) $ts;
> set time($file) -$ts;
> set peer($file) $socket;
> set peer($socket) $file;
> incr count;
> incr pcount;
> incr nbrconn;
> if {[catch getfreebuf res]} {
>      toobusy $file "Too many connections ($nbrconn) ($res), reload in
> few moments"
>      return;
> }
> set bufid($socket) $res;
> after $stimeout "stimeout $socket $ts"
> #puts "Sending $method $what to $host:$port"
> # send the httpd query :
> if {![cequal $apline ""]} {set more "\n$apline\r"} else {set more ""}
> set what "$method $what HTTP/1.0\r$more
> User-Agent: tclproxy/dl$version
> (http://www.box.eu.org/~dl/wwwtools.html)\r
> Accept: */*\r
> \r\n"
> set lg [string length $what];
> bin_new query buffer $lg;
> regsub -all {\\} $what {\\\\} what;
> set query(_str_) $what;
> set wrote [bin_write $socket query];
> if {$wrote<$lg} {puts "probable error on $socket : $wrote<$lg"}
> if {$contentLG>0} {
>   global bufrst;
>   set contentWR [bin_write $socket bufrst];
>   if {$contentWR<$contentLG} {puts "probable post error on $socket :
> $contentWR<$contentLG"} elseif {$debug>=3} {
>   puts "sent request&post data ($wrote+$contentWR bytes) on $socket"
>   }
> } elseif {$debug>=3} {
>   puts "sent request ($wrote bytes) on $socket"
> }
> if [catch {flush $socket} msg] {puts "flushing error $msg"}
> fileevent $socket r "trans_handler $file r $socket";
> }
>
> # *** WWW utilities extracted from my other stuff :
>
> # *** base64.tcl
>
> # authorisation mecanism
> # Base64 <-> String  Translation, in TclX,
> # 9/1995 by Laurent Demailly - ld...@ma... -
> http://www.box.eu.org/~dl/
> # Free Software - No warranty
>
> set _pad "="
> set _base64 \
>   "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/"
>
> # encode a tcl string using base64 mime like coding
> proc StrTo64 {bin} {
>   global _pad _base64;
>   set lg [clength $bin]
>   set res {};
>   loop i 2 $lg 3 {
>     scan [crange $bin $i-2 $i] %c%c%c a b c;
>     append res [cindex $_base64 [expr $a>>2]];
>     append res [cindex $_base64 [expr (($a&03)<<4) | ($b>>4)]];
>     append res [cindex $_base64 [expr (($b&017)<<2)| ($c>>6)]];
>     append res [cindex $_base64 [expr  ($c&077)]];
>   }
>   if {$lg%3} {
>     set b 0;
>     scan [crange $bin $i-2 $i] %c%c a b;
>     append res [cindex $_base64 [expr $a>>2]];
>     append res [cindex $_base64 [expr (($a&03)<<4) | ($b>>4)]];
>     if {$lg%3==1} {
>       append res $_pad$_pad;
>     } else {
>       append res [cindex $_base64 [expr ($b&017)<<2]];
>       append res $_pad;
>     }
>   }
>   return $res;
> }
>
> # restore string that was base64 encoded. If there are encoded '\0'
> they
> # will simply be skipped
> proc 64ToStr {coded} {
>   global _base64 _pad;
>   set lg [clength $coded];
>   if {$lg%4} {error "Invalid length $lg for a base 64 encoded string"}
>   set res {};
>   loop i 0 $lg 4 {
>     loop j 0 4 {
>       set c [cindex $coded $i+$j];
>       set n$j [string first $c $_base64];
> # comment out /remove the sanity tests below for better performance:
>       if \$n$j==-1 {
>         if {[cequal $c $_pad]} {
>           if {$i+$j<$lg-2} {
>             error "illegal padding char early in base64 coded string"
>           }
>         } else {
>           error "illegal char '$c' for a base64 coded string"
>         }
>       }
>     }
>     append res [format %c [expr ($n0<<2)+($n1>>4)]];
>     if $n2==-1 {
>       if $n3!=-1 {
>         error "last char is not pad while the one before is ('$_pad')"
>       }
>     } else {
>       append res [format %c [expr (($n1 & 0xf)<<4)+($n2>>2)]]
>       if $n3!=-1 {append res [format %c [expr (($n2 & 3)<<6)+$n3]]}
>     }
>   }
>   return $res;
> }
>
> # *** uncgi.tcl
>
> # from UnCgi Translation hack, in Tcl, v1.5 5/1995 by
> dl...@ww...
> proc uncgi {buf} {
> regsub -all {\\(.)} $buf {\1} buf ;
> regsub -all {\\} $buf {\\\\} buf ;
> regsub -all { }  $buf {\ } buf ;
> regsub -all {\+} $buf {\ } buf ;
> regsub -all {\$} $buf {\$} buf ;
> regsub -all \n   $buf {\n} buf ;
> regsub -all {;}  $buf {\;} buf ;
> regsub -all {\[} $buf {\[} buf ;
> regsub -all \" $buf \\\" buf ;
> regsub  ^\{ $buf \\\{ buf ;
> regsub -all -nocase {%([a-fA-F0-9][a-fA-F0-9])} $buf {[format %c
> 0x\1]} buf
> eval return \"$buf\"
> }
>
> # *** parse cgi message
>
> # returns in the 'cgi' array all the parameters sent to the script
> # through 'message' (each array cell is a list (ie if only one value
> # is expected through 'test' variable, use [lindex $cgi(test) 0] to
> get it)).
> proc parse_cgi_message {message} {
> global cgi;
> set cgi() "";
> foreach pair [split $message &] {
>   set plst [split $pair =];
>   set name [uncgi [lindex $plst 0]];
>   set val  [uncgi [lindex $plst 1]];
>   lappend cgi($name) $val;
> }
> }
>
> # *** end of included utilities
>
> # Admin Check access
> proc admincheck {host user pass} {
>   global debug;
> if {$debug>=2} {
>   puts "A $user@$host"
> }
>   # because passwd are sent almost clear, allow only localhost
> connects:
>   if {![cequal $host 127.0.0.1]} {return 1}
>   # (note that it is only because the proxy strips headers that it
> can't
>   #  be used against itself to 'appear' from localhost)
>
>   # using running name as user  (this is not a secret !)
>   global env;
>   if {![cequal $user $env(LOGNAME)]} {return 1}
>   # passcheck, using md5 digest
>   if {![info exists env(APROXYPASS)]} {
>     puts "APROXYPASS env var not defined!";
>     return 1;
>   }
>   if {![cequal [md5sum $pass] $env(APROXYPASS)]} {return 1}
>   return 0; # access granted
> }
>
> proc md5sum {what} {
>   bin_new d digest 16;
>   bin_new w object [clength $what];
>   regsub -all {\\} $what {\\\\} what;
>   set w(_str_) $what;
>   md5 d w;
>   return $d(_hex_);
> }
>
> proc admin {file getflag host user pass} {
>   global nbrconn absmaxconn count pcount dateup trkbytes fqhn port
> freebuflst \
>          nbrhops autoroute allowpost;
>   htmlblah $file $getflag "Proxy HTTP Server Admin" \
>         "Welcome $user, from $host on the WWW proxy server
> administration page
> <p>
> <form action=\"/debug\" method=\"Post\">
> Number of hops (must be &lt;= number of proxies in the route list):
>  <input name=\"nbrhops\" value=\"$nbrhops\" size=3><p>
> Proxy route list (each proxy as host:port):<br>
> <input name=\"autoroute\" value=\"$autoroute\"
> size=[expr [clength $autoroute]+15]><p>
> Allow Post:
> <input type=\"checkbox\" name=\"post\" [if $allowpost {set res
> CHECKED}]><p>
> <input type=\"submit\" value=\"Change! (Not yet working)\">
> </form>
> <p>
> Currently: $nbrconn/$absmaxconn open connections,<br>
> Free buffers: $freebuflst<br>
> Served a total of $count requests since $dateup<br>
> Proxy requests: $pcount, transmitted [format %.1f $trkbytes] kbytes
> <p>
> <a href=\"/\">Back to server root</a>
> "
> }
>
> # store the source
> set sname [info script]
> set fic [open $sname]
> set source  [read $fic]
> set slength [clength $source]
> set schk    [md5sum  $source]
> close $fic;
>
> proc sendsource {file getflag} {
>   global source slength schk version;
> # we have to increase the buffer so we can write the whole source in
> # a single puts
>   fconfigure $file -buffersize 32768;
>   catch {
>     set title "Document follows"
>     puts $file "HTTP/1.0 200 Document follows
> Server: tclProxy/dl$version (infos on
> http://www.box.eu.org/~dl/wwwtools.html)
> Content-Type: text/plain
> Content-Length: $slength
> Content-Digest: MD5=$schk
> "
>    flush $file;
>    if $getflag {puts -nonewline $file $source}
>   }
>   do_close $file "source sent";
> }
>
> set version "${version}d${debug}"
>
> # background error handler (exit with trace output)
> proc tkerror {mess} {
> global errorInfo;
> puts stderr "BACKGROUND ERROR : $mess";
> puts stderr "ERRORINFO: $errorInfo";
> exit 0;
> }
>
> set errorInfo {};
>
> puts "sourced ok"
> vwait forever;
> #EOF
>
> (end of original message)
> --------------------------------------------------------------------------
--
> --
>
> You can view this message and the related discussion by following this
link:
>
http://www.deja.com/%5bST_rn%3dap%5d/dnquery.xp?search=thread&svcclass=dnser
> ver&recnum=%3c3...@ne...%3e%231/8
> We hope to see you soon at Deja.com.
> Before you buy.
> http://www.deja.com/%5bST_rn%3dap%5d/
>
> -----Original Message-----
> From: tcl...@li...
> [mailto:tcl...@li...]On Behalf Of Jacob
> Levy
> Sent: Saturday, December 02, 2000 10:57 AM
> To: tcl...@li...
> Subject: [Tclhttpd-users] Q: Using TclHTTPD as a proxy server?
>
> Two questions:
>
> * Is it possible to use TclHTTPD as a proxy server? If so, how? A
> cookbook explanation would be nice. Thanks!
> * Is it possible to use TclHTTPD both as a proxy server and as a local
> web server at the same time? Again, a cookbook example piece of code
> would be appreciated.
>
> Thanks! --JYL
>
> _______________________________________________
> TclHttpd-users mailing list
> Tcl...@li...
> http://lists.sourceforge.net/mailman/listinfo/tclhttpd-users
>
> _______________________________________________
> TclHttpd-users mailing list
> Tcl...@li...
> http://lists.sourceforge.net/mailman/listinfo/tclhttpd-users

Re: [Tclhttpd-users] Q: Using TclHTTPD as a proxy server?

[Jacob L. <jy...@be...>]

David

Thanks!

I was thinking of something simpler. Since there's probably a way to start the
server as a proxy on a certain port, I'd start it on (for example) port 3333 as
a proxy and as usual on port 8015 as a server. That way I'd have two copies of
the server running within one process. AFAIK it's already possible to run
TclHTTPD as a server serving multiple ports (e.g. 8015 and 8080) at the same
time, so this would be a small change.

Comments?

David LeBlanc wrote:

> This might not be exactly a cookbook, but here it is fwiw.
>
> The use of tclhttpd as a proxy server is a recurring question on the list.
>
> Dave LeBlanc
> ****************************************************************
>
> Subject: Proxy Server Using TCL (Please disregard previous post, forgot
> non-binary group! =-)
> From: lu...@pi...
> Date: 1999/05/16
> Newsgroups: comp.lang.tcl
> I am assisting a good friend with this final project, which he needs
> to graduate and I hope someone here can lend a little help if
> possible. Included in this message below is a proxy server written in
> TCL,
> saved in text format. The question he's grappling with is:
>
> Suppose your proxy were ALSO a server.  At what point or points in the
> code (indicate the exact routine and line) would you branch to server
> functionality?  Why?
>
> I'm not familiar with TCL(neither is he) and he needs it by Tuesday in
> order to graduate. =-( Hate to be a bother or anything, but if anyone
> can help, please email me a response to:
>
> lu...@pi...
>
> If anything, I'm hoping this code will assist others with similar
> projects, as sometimes stuff like this is tough to come by. =-)
>
> Thanks...
>
> #!/bin/sh
> # the next line restarts using tclsh \
> exec tclsh "$0" $@
>
> #
> # $Id: http_proxy.tcl,v 4.4 1997/01/30 00:01:19 dl Exp $
> #
> # An Privacy enhanced http proxy,
> # initially based on my geturl2 raw WWW client and my tclhttpd
> # (suitable for anonymous web access)
> #
> # Sample usage:
> #    nohup http_proxy listeningport [nbrhops prox1 ... proxyn] >
> /dev/null &
> # if nbrhops and proxyI are provided,
> # the proxy will generate a random route of nbrhops hops,
> # amongst proxy 1...N   (nbrhops must be >= N)
> #
> # You can see/modify the parameters using your web browser, accessing
> #   http://localhost:listeningport/admin
> # To do this you shall define an APROXYPASS environement variable,
> equal
> # to the md5 digest/checksum of your password, for access to
> # the proxy admin page (use 'md5sum "pass"' proc to get the value)
> # For instance, to use the string 'passwd' as password, use :
> # setenv APROXYPASS 76a2173be6393254e72ffa4d6df1030a
> #
> # NB: POST support and admin parameters modification is not yet
> finished.
> #
> # You need a Binary tcl shell : tcl7.5 or later + tclbin +(and
> optionally tclX)
> # interp to use it
> # ( tcl7.5 needed to listen to tcp port and clock, tclX for
> lassign,etc
> #  and tclbin for real binary IOs, md5 checksum/digest interface,...)
> #
> # To build this shell you need the tclbin distrib
> # http://www.box.eu.org/~dl/tclbin.html and ftp://ftp.box.eu.org/tcl/
> # C source files compressed tar file : tclbin-*.tgz  (currently v1.2)
> #
> # THIS IS A BETA RELEASE - PLEASE DON'T DISSEMINATE
> #
> # (c)1995 by Laurent Demailly - dl...@ww...
> #            http://www.box.eu.org/~dl/
> #
> # Latest version shall always be available from
> # http://www.box.eu.org/~dl/wwwtools.html
> #
> # (please send me feed back, comments, and tell me if you made
> changes,...)
> #
> # ``Artistic'' license see LICENSE - Author: Laurent Demailly
> #
> # This program is free software; you can redistribute it and/or modify
> # it under the terms and CONDITIONS of the included LICENSE
> #
> # If you don't have the LICENSE or need to clarify anything please
> # contact the author
> #
> # This program is distributed in the hope that it will be useful,
> # but WITHOUT ANY WARRANTY; without even the implied warranty of
> # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
> #
> # $Log: http_proxy.tcl,v $
> # Revision 4.4  1997/01/30 00:01:19  dl
> # updated urls and emails. fix in 64ToStr.
> #
> # Revision 4.3  1996/05/08  13:41:04  dl
> # fixed huge bug of unreturned buffer because notreadylock() was not
> unset
> #
> # Revision 4.2  1996/05/02  22:39:03  dl
> # missing -translation binary was causing garbage on binary files
> #
> # Revision 4.1  1996/05/02  21:58:44  dl
> # Tcl(7.5) + tclbin only version (and optional tclX)
> # no more tcldp.
> # no 100% finished yet [the write blocking must be reimplemented
> nicely]
> #
> # Revision 3.8  1996/04/22  18:54:47  dl
> # added a lock for client waiting / close while waiting case
> # typo/bugfix peer was not declared global in main handler
> #
> # Revision 3.7  1996/04/09  15:52:04  dl
> # Don't send more bytes than "Content-Length" in request, even if
> client does
> #
> # Revision 3.6  1996/04/09  15:32:01  dl
> # added `small' POST requets support ! (which implied a binary read of
> # headers/client too...)
> # optional passing of Authorization* headers
> #
> # [old logs deleted for space sake]
>
> # If you didn't "make install"
> # copy libdlbin.sl to /usr/local/lib/tcl7.5
> # and run
> # echo 'pkg_mkIndex /usr/local/lib/tcl7.5 *[info sharedlibextension]'|
> tclsh7.5
> # or
> #lappend auto_path .
> # to test it in current directory
>
> package require Bin;
> package require Mdfive;
>
> if [catch {package require Tclx} res] {
>   puts "Running without tclX ($res) (using compat in tcl lib, a bit
> slower)";
> # Some minimal TclX replacements...
> proc getclock {} {clock seconds}
> proc lempty {lst} {regexp "\[ \t\n\]" $lst}
>
> proc fmtclock {clockval {format {}} {zone {}}} {
>     lappend cmd clock format $clockval
>     if ![lempty $format] {
>         lappend cmd -format $format
>     }
>     if ![lempty $zone] {
>         lappend cmd -gmt 1
>     }
>     return [eval $cmd]
> }
> # simple one (no step/no continue...)
> proc loop {var start end body} {
>   upvar $var v;
>   for {set v $start} {$v<$end} {incr v} {
>     uplevel $body;
>   }
> }
> proc lassign {list args} {
>   set i 0;
>   foreach vname $args {
>     uplevel [list set $vname [lindex $list $i]];
>     incr i;
>   }
>   lrange $list $i end
> }
> proc clength {str} {string length $str}
> proc cequal {s1 s2} {expr [string compare $s1 $s2]==0}
> # simple, we don't do "end"
> proc crange {str first last} {string range $str [expr $first] [expr
> $last]}
> # tcl-usage' faq random :
> proc random {args} {
>   global RNG_seed;
>
>   set max 259200;
>   set argcnt [llength $args];
>   if { $argcnt < 1 || $argcnt > 2 } {
>     error "wrong # args: random limit | seed ?seedval?"
>   }
>   if ![string compare [lindex $args 0] seed] {
>     if { $argcnt == 2 } {
>       set RNG_seed [lindex $args 1]
>     } else {
>       set RNG_seed [clock clicks] ; # poor...
>     }
>     return;
>   }
>   if ![info exists RNG_seed] {
>     set RNG_seed [clock clicks] ; # poor...
>   }
>   set RNG_seed [expr ($RNG_seed*7141+54773) % $max]
>   return [expr int(double($RNG_seed)*[lindex $args 0]/$max)]
> }
> proc lvarpop {var} {
>   upvar $var v;
>   set r [lindex $v 0];
>   set v [lrange $v 1 end];
>   return $r;
> }
> }
>
> #
> # ---------- start of CONFIGURABLE section ----------
>
> # max simultaneous proxy connections allowed
> set maxconn 4
> # absolute maximum (each proxy requires 2 connections)
> set absmaxconn [expr 2*$maxconn];
> # timeout in seconds for getting a query  (in milli-seconds)
> set qtimeout 20000;
> # timeout for the whole connect  (600000 = 10 mins)
> set stimeout 120000 ; # two minutes is enough (we want to be fast)
> # buffer size for one connection
> set bufsz 32768 ;#16384; #8192
>
> # set denied(aaa.bbb.ccc.ddd) 1;
>
> # proc that is called for each connecting IP and shall return 0 for ok
> # and 1 for denied.
> proc access_forbid {host} {
>   global denied;
> # like this, unless host is found in the above 'denied' array, access
> granted
> # but this proc can be complexified at will to support any kind of
> access ctrl
>   info exists denied($host)
> }
>
> # ---------- end of configurable section ----------
>
> # determine this server host and domain name :
>
> # Note: on some OS/configs hostname is directly the fqhn
> # (for me, not)
> set hostname [lindex [split [exec hostname] .] 0];
> # the running host full qualified name (host.domain name)
> set fqhn [exec nslookup $hostname]
> regexp "Name: +(\[^\n\]+)\n" $fqhn all fqhn;
> # domain name alone
> regexp {^([^\.]+)\.(.+)$} $fqhn all hn domain;
> # (btw hn should be == hostname)
>
> # record starting time
> set dateup [fmtclock [getclock] "%d %h %Y %H:%M %Z" GMT];
>
> #
> # Buffer setup
> #
>
> # total buffer size
> set bigbufsz [expr $bufsz*$maxconn];
>
> bin_new bigbuf buffer $bigbufsz;
> set freebuflst {};
>
> loop i 0 $maxconn {
>   # split the big buf in smaller shunks
>   bin_new buf${i} buffer $bufsz bigbuf $i*$bufsz;
>   bin_new buf${i}in  buffer $bufsz buf${i};
>   bin_new buf${i}out buffer 0      buf${i};
>   lappend freebuflst $i;
> }
>
> proc getfreebuf {} {
>   global freebuflst;
>   set res [lvarpop freebuflst]
>   if {[cequal $res ""]} {error "no more bufs!"}
>   return $res
> }
>
> proc givebackbuf {i} {
>   global freebuflst;
>   lappend freebuflst $i;
>   global buf${i}in buf${i}out;
>   bin_move -absolute buf${i}out 0;
>   bin_move -absolute buf${i}in  0;
>   global bufsz;
>   bin_resize buf${i}in $bufsz;
> }
>
> # by default, only one routing
> set autoroute {}
> set nbrhops 0;
> # by default, post is not allowed
> #set allowpost 0;
> set allowpost 1;
>
> # allow authorization* headers ?
> set allowauth 1;
>
> # rcs kewords extraction
> regexp {[.0-9]+} {$Revision: 4.4 $} version
>
> # Proxy List keyword in http header:
> set plistkeyw "ProxyControl";
> # Protocol Version
> set plistvers 1
>
> # debug ?
> set debug 2
> if {[info exists env(DEBUG)]} {
>   set debug $env(DEBUG);
>   if {[catch {expr $debug>0}]} {set debug 0}
> }
>
> #
> # proxy transfer handler, called when there is something to read
> # on the socket server socket (copy it to the client):
> #
> proc trans_handler {cliconn mode servconn {recurs 0}} {
>   global trkbytes debug;
> #  puts "called trans_handler $cliconn $servconn $recurs";
>   global bufid bufsz;
>   set id $bufid($servconn);
>   upvar buf${id}in  bufin ;
>   upvar buf${id}out bufout ;
>
>   if {[catch {bin_sizeof bufin} sz1]} {
>     puts "hmmm error '$sz1' for id=$id, on
> $cliconn,$servconn,$recurs";
>     do_close $cliconn "error bufin!";
>   }
>   if {$sz1!=0} {
>     if {[catch {set n [bin_read $servconn bufin]} res]} {
>       set n 0;
> if {$debug>=1} {
>       puts "th $cliconn $servconn : got read error : $res";
> }
>     }
> if {$debug>=3} {
>     puts "th $cliconn $servconn : read $n/$sz1 bytes";
> }
>   } else {
>     set n 0;
> if {$debug>=3} {
>     puts "th $cliconn $servconn : read buffer full, no read";
> }
>   }
>   if {$n==0} {
>     if {[bin_sizeof bufout]==0} {
>       do_close $cliconn "transmit done (now $trkbytes kb)";
>       return;
>     }
>   } else {
>     bin_resize bufin $sz1-$n;
>     set szi [bin_move bufin $n 1];
> # we got a bug in the resize below... (should be fixed by the
> notreadylock..)
> #puts "trh c=$cliconn m=$mode s=$servconn r=$recurs
> n=$n,sz1=$sz1,szi=$szi";
>     if {[catch {bin_resize bufout $szi-[bin_move bufout 0]} msg]} {
>       puts "error resize bufout: [bin_info bufout]";
>       tkerror $msg;
>     }
>   }
>
>   if {$recurs} {return $n}
>
> #  if {[lempty [lindex [select {} $cliconn {} .2] 1]]}
> #  global writable
> #  set writable($cliconn) 0
> #  fileevent $cliconn w "set writable($cliconn) 1";
> #  puts "before vwait writable($cliconn)";
> #  fileevent $servconn r {};
> #  vwait writable($cliconn);
> #  fileevent $servconn r "trans_handler $cliconn r $servconn";
> #  puts "after  vwait writable($cliconn)";
>
>   if {0} { # with tcl7.5 we can always write... (!)
>     # not ready to write...
> if {$debug>=3} {
>     puts "th $cliconn $servconn : client not ready 1 for writing";
> }
>     fileevent $servconn r {};
>     global notreadylock;
>     set notreadylock($servconn) 1;
>     update
>     if {!$notreadylock($servconn)} {
>       # socket have been closed in update, finish do_close' job
>       givebackbuf $bufid($servconn);
>       unset bufid($servconn);
>       unset notreadylock($servconn);
>       return ;
>     }
>     while {[lempty [lindex [select {} $cliconn {} .2] 1]]} {
> if {$debug>=2} {
>       puts "th $cliconn $servconn : client not ready n for writing";
> }
>       update;
>       if {!$notreadylock($servconn)} {
>         # socket have been closed in update, finish do_close' job
>         givebackbuf $bufid($servconn);
>         unset bufid($servconn);
>         unset notreadylock($servconn);
>         return ;
>       }
>       if {[uplevel #0 trans_handler $cliconn $mode $servconn 1]==0} {
>         loop i 0 4 {
>           after 250
>           update
>           if {!$notreadylock($servconn)} {
>             # socket have been closed in update, finish do_close' job
>             givebackbuf $bufid($servconn);
>             unset bufid($servconn);
>             unset notreadylock($servconn);
>             return ;
>           }
>         }
>       }
>     }
>     unset notreadylock($servconn);
>     fileevent $servconn r "trans_handler $cliconn r $servconn";
>   }
>
>   set sz2 [bin_sizeof bufout];
>   if {[catch {set p [bin_write - $cliconn bufout]} res]} {
>     set p 0;
> if {$debug>=1} {
>     puts "th $cliconn $servconn : got a write error : $res";
> }
>   }
> if {$debug>=3} {
>   puts "th $cliconn $servconn : wrote $p/$sz2";
> }
>   bin_resize bufout $sz2-$p;
>   if {$p==$sz2} {
> # everything was read
> #    puts "reset";
>     bin_move -absolute bufout 0;
>     bin_move -absolute bufin  0;
>     bin_resize bufin $bufsz;
>   } else {
>     bin_move bufout $p 1;
>   }
> #  catch {flush $cliconn}
>   set trkbytes [expr $trkbytes+$n/1024.];
> #  puts "th $cliconn $servconn : transmitted $n bytes -> $trkbytes";
> }
>
> #
> # usage / startup error
> #
> proc usage {msg} {
> puts stderr "Error $msg";
> puts stderr "Usage: [info script] port \[nbrhops proxy1 ...proxyN\]";
> exit 1;
> }
>
> if {$argc==0} {usage "no port given!"};
>
> lassign $argv port;
> if {$argc==2} {usage "nbrhops given but no proxies!"};
> if {$argc>2} {
>   set nbrhops [lindex $argv 1];
>   set autoroute [lrange $argv 2 $argc];
>   set lg [llength $autoroute];
>   if {[catch {expr $nbrhops>$lg} res]} {usage "nbrhops is not a
> number!"};
>   if {$res} {usage "nbrhops > number of proxies given!"};
> };
>
> # listen on port
> set srv [socket -server newconn $port]
> # init counters and stat:
> set nbrconn 0;
> set count 0;
> set pcount 0;
> set trkbytes 0.0;
>
> # connect handler:
> puts stderr "listening on host $fqhn ($hostname,$domain) on port
> $port";
> puts stderr "nbrhops=$nbrhops, autoroute=($autoroute)";
>
> # accept connects:
> proc newconn {socket host port} {
>   global count absmaxconn nbrconn qtimeout time queue ql debug;
>   set ts [getclock];
> if {$debug>=1} {
>   puts "C $ts ($nbrconn,$count) $host -> $socket";
> }
>   incr count;
>   if {[access_forbid $host]} {
> if {$debug>=0} {
>     puts "denied $host";
> }
>     catch {close $socket};
>     return
>   }
>   incr nbrconn;
> #  dp_socketOption $socket sendBuffer 16384;
>   fconfigure $socket -blocking no -translation binary;
> #  dp_socketOption $socket keepalive yes;
>   if {$nbrconn>$absmaxconn} {
>      toobusy $socket "Too many connections ($nbrconn), reload in few
> moments"
>      return;
>   };
>   set time($socket) $ts;
>   set queue($socket) {};
>   set ql($socket) 0;
>   fileevent $socket r "handler $host r $socket";
>   after $qtimeout "qtimeout $socket $ts"
> }
>
> proc qtimeout {file ts} {
>   global time;
>   #puts "called timeout $file $ts";
>   if {[info exists time($file)]} {
>     #puts "times($file)=$times($file)";
>     if {$time($file)==$ts} {
>       serror $file "Received no valid query" 408 "Request Timeout";
>     }
>   }
> }
>
> proc stimeout {file ts} {
>   global time;
>   #puts "called timeout $file $ts";
>   if {[info exists time($file)]} {
>     #puts "times($file)=$times($file)";
>     if {$time($file)==$ts} {
>       do_close $file "session too long";
>     }
>   }
> }
>
> # read buffer
> bin_new buffer buffer 16384;
> bin_new bufptr buffer 0 buffer;
> bin_new bufrst buffer 0 buffer;
>
> # Main connection handler
> # determines what is requested and what to call for answer
> #
> proc handler {host mode file} {
>   global peer time queue ql plistkeyw plistvers debug \
>      fqhn hostname domain port nbrhops autoroute allowpost allowauth;
>   set what {};
>   global buffer bufptr bufrst;
>   if {[catch {bin_read $file buffer} lg]} {
>     do_close $file "read error '$lg'";
>     return;
>   }
> #  puts "called handler $file : read '$what'";
>   if {$lg==0} {do_close $file "eof"; return}
>   if {[info exists peer($file)]} {return}; #ignore what client says
> after conn
>   bin_resize bufptr $lg;
>   set what $bufptr(_str_);
>   regsub -all {\\.} $what {\\} what; # so [clength $what] is r
>   # (side effect: if there are '\0' in headers (which is illegal),
>   # they'll appear as '\')
>   append queue($file) $what;
>   # header is fully here ? (if not we just wait)
>   if {![regexp -indices "\r?\n\r?\n" $queue($file) idx]} {
>     if {($ql($file)+$lg)>1024} {
>       serror $file "" 400 "Query too long"
>     } else {
>       incr ql($file) $lg;
>     }
>     return;
>   }
>   # cool, we found the header separation
>   lassign $idx p1 p2;
>   set rest [expr $lg-($p2+1-$ql($file))];
>   bin_resize bufrst $rest;
>   if {$rest!=0} {
>     bin_move -absolute bufrst $lg-$rest 1;
> if {$debug>=4} {
>   puts "remaining $rest bytes! ($bufrst(_str_))";
> }
>   }
>   set what [crange $queue($file) 0 $p1-1];
>   regsub -all "\r" $what {} what;
>   if {![regexp \
> "^(\[^ \n\]+) (\[^ \n\]+) HTTP/1.0(\n(.+\n)?($plistkeyw: V(\[0-9\]+)
> ?(\[^\n\]*))\n)?"\
>    $what gall method url r1 r2 apline apvers aplist]} {
>     # wrong command... problem
>     serror $file \
>            "Format unrecognized:\n<pre>\n[txt2html $what]</pre>" \
>            400 "Bad Request";
>     return;
>   }
>   if {![regexp {^(GET|HEAD|POST)$} $method]} {
>     # not implemented method
>     serror $file \
>       "Sorry, the method <strong>$method</strong> is not
> implemented.\n\
>       <p>Your query was\n<pre>\n[txt2html $what]</pre>" \
>       501 "Not Implemented ($method)";
>     return;
>   }
>   # if a local url is requested, skip proxying it :
>   if {[regsub -nocase
> "^http://($fqhn|$hostname|localhost(\.$domain)?|127\.0\.0\.1):$port/"
> $url / url]} {
> if {$debug>=3} {
>     puts "url found to be local ($url)"
> }
>   }
>   # Do we want full thing or headers only?
>   set getflag [expr ![cequal $method "HEAD"]];
>   set postflag [cequal $method "POST"];
>   set moreheaders {};
>   set contentLG 0;
>   if {$postflag} {
>     # get and check content-length
>     set contentLG 0;
>     regexp -nocase {Content-length: *([0-9]+)} $what all contentLG;
>     if {$contentLG>$rest} {
>       serror $file "I can't handle this post request because\
> \nYou have to send $contentLG bytes and I've read only $rest bytes..."
> \
>       500 "Can't handle this Post $rest/$contentLG";
>       return;
>     }
>     if {$contentLG>0} {bin_resize bufrst $contentLG}
>     # extract/save all Content-* headers
>     set all $what;
>     while {[regexp -nocase "\n(Content-\[^\n\]+)(.*)$" $all a ct all]}
> {lappend moreheaders $ct}
>   }
>   if {$allowauth} {
>     set all $what;
>     while {[regexp -nocase "\n(Authorization\[^\n\]+)(.*)$" $all a ct
> all]} {lappend moreheaders $ct}
>   }
>   if {$debug>5} {puts "content=($moreheaders), contentLG=$contentLG"}
>   switch -regexp -- $url {
>       {^/admin}   {
>         if {[regexp -nocase "\nAuthorization: +Basic +(\[^\n\]+)" \
>                     $what all auth]} {
>           set user "";
>           set pass "";
>           regexp {^([^:]+):(.+)$} [64ToStr $auth] all user pass;
>           if {[admincheck $host $user $pass]} {
>             serror $file "Bad host/user/passwd" 401 \
>               "Unauthorized" "WWW-Authenticate: Basic
> realm=\"admin\"\n";
>           } else {
>             admin $file $getflag $host $user $pass;
>           }
>         } else {
>           serror $file "You need an authorisation capable browser to
> access" \
>             401 "Unauthorized" "WWW-Authenticate: Basic
> realm=\"admin\"\n";
>         }
>       }
>       {^/source} {sendsource     $file $getflag}
>       {^/}       {sendserverinfo $file $getflag [txt2html
> $queue($file)]}
>       default {
>         if {$postflag && !$allowpost} {
>           serror $file "POST is disabled.\n\
>           <p>Your query was\n<pre>\n[txt2html $queue($file)]</pre>" \
>           403 "Forbidden";
>           return;
>         }
>         # real proxy job:
>         # parse the url :
>         if {![regexp {^http://([^/:]+)(:([0-9]+))?(/[^#]*)?(#.*)?$}
> $url \
>                      all dhost p dport what key]} {
>             # for instance port must be numerical
> if {$debug>=2} {
>         puts "invalid url='$url' ($queue($file))";
> }
>             serror $file "<pre>$url</pre>" 400 "Invalid Proxy URL";
>             return;
>           }
>         if {[cequal $dport ""]} {set dport 80}
>         if {[cequal $what ""]} {set what "/"}
> # port checking #1/2 :
>         if {$dport<1024 && $dport!=80} {serror $file "Illegal dest.
> port $dport" 403 "Forbidden"; return}
>         set apflag [expr [cequal $apline ""]==0];
> if {$debug>=1} {
>         puts "$file -> proxying $method http://$dhost:$dport$what
> ($apline)";
> }
>         if {$apflag} {
>           if {([catch {expr $apvers!=$plistvers} res] || $res)} {
>            serror $file "<pre>$apline</pre>" 500 "Invalid Proxy Ctrl
> Version";
>            return;
>           }
>           if {[catch {llength $aplist} lg]} {
>            serror $file "<pre>$aplist</pre>" 400 "Invalid Proxy List";
>            return;
>           }
>         } else {
>           if {$nbrhops!=0} {
>             # generate a random proxy route, choosen in autoroute
>             set aplist [random_path $nbrhops $autoroute [llength
> $autoroute]];
>             set lg [llength $aplist];
> if {$debug>=1} {
>             puts "generated random path ($aplist)";
> }
>           } else {set lg 0}
>         }
>         if {$lg>=1} {
>           set thisproxy [lindex $aplist 0];
>           set restproxy [lrange $aplist 1 $lg];
>           if {![regexp {^(.+):([0-9]+)$} $thisproxy all phost pport]}
> {
>             serror $file "<pre>$thisproxy</pre>" 400 "Invalid Next
> Proxy Entry";
>             return;
>           }
>           lappend moreheaders "$plistkeyw: V$plistvers $restproxy";
> # port checking #2/2 :
>           if {$pport<1024 && $pport!=80} {serror $file "Illegal proxy
> port $pport" 403 "Forbidden"; return}
>           do_query $file $method $phost $pport \
>              "http://$dhost:$dport$what" [join $moreheaders \r\n]
> $contentLG;
>         } else {
>           lappend moreheaders $apline;
>           do_query $file $method $dhost $dport $what [join
> $moreheaders \r\n] $contentLG;
>         }
>       }
>     }
> }
>
> proc random_path {n list lg} {
>  set idx [random $lg]
>  if {$n>1} {
>    incr n -1;
>    incr lg -1;
>    return "[lindex $list $idx] [random_path $n [lreplace $list $idx
> $idx] $lg]"
>  } else {
>    return "[lindex $list $idx]"
>  }
> }
>
> proc txt2html {str} {
> regsub -all "&" $str {\&amp;} str;
> regsub -all "<" $str {\&lt;} str;
> regsub -all ">" $str {\&gt;} str;
> regsub -all \" $str {\&quot;} str;
> return $str;
> }
>
> proc toobusy {file msg} {
>   serror $file "$msg\n<p>Try to <b>reload</b> in a moment" 503
> "Service Overloaded" \
>              "Retry-After: 15\n";
> }
>
> proc serror {file msg {id 500} {title "Error"} {more ""}} {
>   global version fqhn port;
>   catch {
>     puts $file "HTTP/1.0 $id $title
> Server: tclProxy/dl$version
> Content-Type: text/html
> $more
> <HEAD><TITLE>$title</TITLE>
> <link rev=\"made\" href=\"mailto:ld...@ma...\">
> </HEAD>
> <BODY>
> <H1>$title</H1>
> $msg
> <HR>
> <ADDRESS>
> <A HREF=\"http://$fqhn:$port\">
> Anonymous proxy httpd</a> v$version server in tcl, by
> <A HREF=\"http://www.box.eu.org/~dl/\">dl</A>
> </ADDRESS>
> </BODY>"
>   }
>   do_close $file "error ($id $title)";
> }
>
> proc htmlblah {file getflag title msg} {
>   global version;
>    set sendstr "<HEAD><TITLE>$title</TITLE>
> <link rev=\"made\" href=\"mailto:ld...@ma...\">
> </HEAD>
> <BODY>
> <H1>$title</H1>
> $msg
> <HR>
> <ADDRESS>
> <A HREF=\"http://www.box.eu.org/~dl/wwwtools.html\">
> Anonymous proxy httpd</a> v$version server in tcl,
> <A HREF=\"http://www.box.eu.org/~dl/disclaimer.html\">&copy;</A>
>  by
> <A HREF=\"http://www.box.eu.org/~dl/\">dl</A>
> </ADDRESS>
> </BODY>
> "
>   set sl  [clength $sendstr];
>   set chk [md5sum  $sendstr];
>   catch {
>     puts $file "HTTP/1.0 200 Document follows
> Server: tclProxy/dl$version
> Content-Type: text/html
> Content-Length: $sl
> Content-Digest: MD5=$chk
> "
>   flush $file;
>   if $getflag {puts -nonewline $file $sendstr}
>   }
>   do_close $file "htmlblah $getflag ($title)";
> }
>
> proc sendserverinfo {file getflag what} {
>   global nbrconn absmaxconn count pcount dateup trkbytes fqhn port
> freebuflst;
>         htmlblah $file $getflag "Anonymous Proxy HTTP Server" "
> Welcome on this experimental WWW proxy server, feel free to use it
> (but not
> abuse it, <b>please</b>), source is
> <a href=\"/source\">here</a> and latest version and informations are
> on
> <a href=\"http://www.box.eu.org/~dl/wwwtools.html\">
> http://www.box.eu.org/~dl/wwwtools.html</a>.<p>
> Use <tt>setenv http_proxy http://$fqhn:$port/</tt> to use it, or
> better, run
> a local copy and join the privacy http proxy network.
> <p>
> Access restricted <a href=\"http://localhost:$port/admin\">proxy
> admin</a>.
> <p>
> Look at the amount of information <em>your</em> browser is sending
> (and this
> proxy is throwing away) :<br>
> See for instance the <a href=\"refered\">Referer:</a> that might
> contain
> very personal informations (back links).
> (Not all browsers put a Referer field, though)
> <pre>
> $what</pre>
> <p>
> Currently: $nbrconn/$absmaxconn open connections,<br>
> Free buffers: $freebuflst<br>
> Served a total of $count requests since $dateup<br>
> Proxy requests: $pcount, transmitted [format %.1f $trkbytes] kbytes"
> }
> #
> # Closing proc
> #
> proc do_close {file msg} {
>   global nbrconn time queue ql peer bufid debug;
> if {$debug>=1} {
>   puts "closing $file ($msg)"; flush stdout;
> }
>   catch {fileevent $file r {} }
>   catch {unset time($file)}
>   catch {unset queue($file)}
>   catch {unset ql($file)}
>   global notreadylock;
>   if {[info exists bufid($file)]} {
>     if {[info exists notreadylock($file)]} {
>       set notreadylock($file) 0; # raise flag so it can given back
> later...
>     } else {
>       givebackbuf $bufid($file);
>       unset bufid($file);
>     }
>   }
>   if {[info exists peer($file)]} {
>     set mypeer $peer($file);
>     unset peer($file);
>     if {[info exists time($mypeer)]} {do_close $mypeer "peer $msg"}
>   }
> #  catch {flush $file}
>   catch {close $file}
>   incr nbrconn -1;
> }
>
> proc do_query {file method host port what apline contentLG} {
> global peer bufid time stimeout version count pcount conn nbrconn
> debug;
> # connect to the host
> if {[catch {set socket [socket $host $port]} msg]} {
>   puts stderr "connect on $host port $port : $msg";
>   serror $file "Connect error on $host port $port : $msg" 404 "Not
> found";
>   return;
> }
> # dp_filehandler $file; #ignore what client migh say now
> # (in fact not, lets detect close)
>
> fconfigure $socket -blocking no -translation binary;
> #dp_socketOption $socket keepalive yes;
> set ts [getclock]
> if {$debug>=1} {
> puts "S $ts ($nbrconn,$count) $host:$port -> $socket";
> }
> set time($socket) $ts;
> set time($file) -$ts;
> set peer($file) $socket;
> set peer($socket) $file;
> incr count;
> incr pcount;
> incr nbrconn;
> if {[catch getfreebuf res]} {
>      toobusy $file "Too many connections ($nbrconn) ($res), reload in
> few moments"
>      return;
> }
> set bufid($socket) $res;
> after $stimeout "stimeout $socket $ts"
> #puts "Sending $method $what to $host:$port"
> # send the httpd query :
> if {![cequal $apline ""]} {set more "\n$apline\r"} else {set more ""}
> set what "$method $what HTTP/1.0\r$more
> User-Agent: tclproxy/dl$version
> (http://www.box.eu.org/~dl/wwwtools.html)\r
> Accept: */*\r
> \r\n"
> set lg [string length $what];
> bin_new query buffer $lg;
> regsub -all {\\} $what {\\\\} what;
> set query(_str_) $what;
> set wrote [bin_write $socket query];
> if {$wrote<$lg} {puts "probable error on $socket : $wrote<$lg"}
> if {$contentLG>0} {
>   global bufrst;
>   set contentWR [bin_write $socket bufrst];
>   if {$contentWR<$contentLG} {puts "probable post error on $socket :
> $contentWR<$contentLG"} elseif {$debug>=3} {
>   puts "sent request&post data ($wrote+$contentWR bytes) on $socket"
>   }
> } elseif {$debug>=3} {
>   puts "sent request ($wrote bytes) on $socket"
> }
> if [catch {flush $socket} msg] {puts "flushing error $msg"}
> fileevent $socket r "trans_handler $file r $socket";
> }
>
> # *** WWW utilities extracted from my other stuff :
>
> # *** base64.tcl
>
> # authorisation mecanism
> # Base64 <-> String  Translation, in TclX,
> # 9/1995 by Laurent Demailly - ld...@ma... -
> http://www.box.eu.org/~dl/
> # Free Software - No warranty
>
> set _pad "="
> set _base64 \
>   "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/"
>
> # encode a tcl string using base64 mime like coding
> proc StrTo64 {bin} {
>   global _pad _base64;
>   set lg [clength $bin]
>   set res {};
>   loop i 2 $lg 3 {
>     scan [crange $bin $i-2 $i] %c%c%c a b c;
>     append res [cindex $_base64 [expr $a>>2]];
>     append res [cindex $_base64 [expr (($a&03)<<4) | ($b>>4)]];
>     append res [cindex $_base64 [expr (($b&017)<<2)| ($c>>6)]];
>     append res [cindex $_base64 [expr  ($c&077)]];
>   }
>   if {$lg%3} {
>     set b 0;
>     scan [crange $bin $i-2 $i] %c%c a b;
>     append res [cindex $_base64 [expr $a>>2]];
>     append res [cindex $_base64 [expr (($a&03)<<4) | ($b>>4)]];
>     if {$lg%3==1} {
>       append res $_pad$_pad;
>     } else {
>       append res [cindex $_base64 [expr ($b&017)<<2]];
>       append res $_pad;
>     }
>   }
>   return $res;
> }
>
> # restore string that was base64 encoded. If there are encoded '\0'
> they
> # will simply be skipped
> proc 64ToStr {coded} {
>   global _base64 _pad;
>   set lg [clength $coded];
>   if {$lg%4} {error "Invalid length $lg for a base 64 encoded string"}
>   set res {};
>   loop i 0 $lg 4 {
>     loop j 0 4 {
>       set c [cindex $coded $i+$j];
>       set n$j [string first $c $_base64];
> # comment out /remove the sanity tests below for better performance:
>       if \$n$j==-1 {
>         if {[cequal $c $_pad]} {
>           if {$i+$j<$lg-2} {
>             error "illegal padding char early in base64 coded string"
>           }
>         } else {
>           error "illegal char '$c' for a base64 coded string"
>         }
>       }
>     }
>     append res [format %c [expr ($n0<<2)+($n1>>4)]];
>     if $n2==-1 {
>       if $n3!=-1 {
>         error "last char is not pad while the one before is ('$_pad')"
>       }
>     } else {
>       append res [format %c [expr (($n1 & 0xf)<<4)+($n2>>2)]]
>       if $n3!=-1 {append res [format %c [expr (($n2 & 3)<<6)+$n3]]}
>     }
>   }
>   return $res;
> }
>
> # *** uncgi.tcl
>
> # from UnCgi Translation hack, in Tcl, v1.5 5/1995 by
> dl...@ww...
> proc uncgi {buf} {
> regsub -all {\\(.)} $buf {\1} buf ;
> regsub -all {\\} $buf {\\\\} buf ;
> regsub -all { }  $buf {\ } buf ;
> regsub -all {\+} $buf {\ } buf ;
> regsub -all {\$} $buf {\$} buf ;
> regsub -all \n   $buf {\n} buf ;
> regsub -all {;}  $buf {\;} buf ;
> regsub -all {\[} $buf {\[} buf ;
> regsub -all \" $buf \\\" buf ;
> regsub  ^\{ $buf \\\{ buf ;
> regsub -all -nocase {%([a-fA-F0-9][a-fA-F0-9])} $buf {[format %c
> 0x\1]} buf
> eval return \"$buf\"
> }
>
> # *** parse cgi message
>
> # returns in the 'cgi' array all the parameters sent to the script
> # through 'message' (each array cell is a list (ie if only one value
> # is expected through 'test' variable, use [lindex $cgi(test) 0] to
> get it)).
> proc parse_cgi_message {message} {
> global cgi;
> set cgi() "";
> foreach pair [split $message &] {
>   set plst [split $pair =];
>   set name [uncgi [lindex $plst 0]];
>   set val  [uncgi [lindex $plst 1]];
>   lappend cgi($name) $val;
> }
> }
>
> # *** end of included utilities
>
> # Admin Check access
> proc admincheck {host user pass} {
>   global debug;
> if {$debug>=2} {
>   puts "A $user@$host"
> }
>   # because passwd are sent almost clear, allow only localhost
> connects:
>   if {![cequal $host 127.0.0.1]} {return 1}
>   # (note that it is only because the proxy strips headers that it
> can't
>   #  be used against itself to 'appear' from localhost)
>
>   # using running name as user  (this is not a secret !)
>   global env;
>   if {![cequal $user $env(LOGNAME)]} {return 1}
>   # passcheck, using md5 digest
>   if {![info exists env(APROXYPASS)]} {
>     puts "APROXYPASS env var not defined!";
>     return 1;
>   }
>   if {![cequal [md5sum $pass] $env(APROXYPASS)]} {return 1}
>   return 0; # access granted
> }
>
> proc md5sum {what} {
>   bin_new d digest 16;
>   bin_new w object [clength $what];
>   regsub -all {\\} $what {\\\\} what;
>   set w(_str_) $what;
>   md5 d w;
>   return $d(_hex_);
> }
>
> proc admin {file getflag host user pass} {
>   global nbrconn absmaxconn count pcount dateup trkbytes fqhn port
> freebuflst \
>          nbrhops autoroute allowpost;
>   htmlblah $file $getflag "Proxy HTTP Server Admin" \
>         "Welcome $user, from $host on the WWW proxy server
> administration page
> <p>
> <form action=\"/debug\" method=\"Post\">
> Number of hops (must be &lt;= number of proxies in the route list):
>  <input name=\"nbrhops\" value=\"$nbrhops\" size=3><p>
> Proxy route list (each proxy as host:port):<br>
> <input name=\"autoroute\" value=\"$autoroute\"
> size=[expr [clength $autoroute]+15]><p>
> Allow Post:
> <input type=\"checkbox\" name=\"post\" [if $allowpost {set res
> CHECKED}]><p>
> <input type=\"submit\" value=\"Change! (Not yet working)\">
> </form>
> <p>
> Currently: $nbrconn/$absmaxconn open connections,<br>
> Free buffers: $freebuflst<br>
> Served a total of $count requests since $dateup<br>
> Proxy requests: $pcount, transmitted [format %.1f $trkbytes] kbytes
> <p>
> <a href=\"/\">Back to server root</a>
> "
> }
>
> # store the source
> set sname [info script]
> set fic [open $sname]
> set source  [read $fic]
> set slength [clength $source]
> set schk    [md5sum  $source]
> close $fic;
>
> proc sendsource {file getflag} {
>   global source slength schk version;
> # we have to increase the buffer so we can write the whole source in
> # a single puts
>   fconfigure $file -buffersize 32768;
>   catch {
>     set title "Document follows"
>     puts $file "HTTP/1.0 200 Document follows
> Server: tclProxy/dl$version (infos on
> http://www.box.eu.org/~dl/wwwtools.html)
> Content-Type: text/plain
> Content-Length: $slength
> Content-Digest: MD5=$schk
> "
>    flush $file;
>    if $getflag {puts -nonewline $file $source}
>   }
>   do_close $file "source sent";
> }
>
> set version "${version}d${debug}"
>
> # background error handler (exit with trace output)
> proc tkerror {mess} {
> global errorInfo;
> puts stderr "BACKGROUND ERROR : $mess";
> puts stderr "ERRORINFO: $errorInfo";
> exit 0;
> }
>
> set errorInfo {};
>
> puts "sourced ok"
> vwait forever;
> #EOF
>
> (end of original message)
> ----------------------------------------------------------------------------
> --
>
> You can view this message and the related discussion by following this link:
> http://www.deja.com/%5bST_rn%3dap%5d/dnquery.xp?search=thread&svcclass=dnser
> ver&recnum=%3c3...@ne...%3e%231/8
> We hope to see you soon at Deja.com.
> Before you buy.
> http://www.deja.com/%5bST_rn%3dap%5d/
>
> -----Original Message-----
> From: tcl...@li...
> [mailto:tcl...@li...]On Behalf Of Jacob
> Levy
> Sent: Saturday, December 02, 2000 10:57 AM
> To: tcl...@li...
> Subject: [Tclhttpd-users] Q: Using TclHTTPD as a proxy server?
>
> Two questions:
>
> * Is it possible to use TclHTTPD as a proxy server? If so, how? A
> cookbook explanation would be nice. Thanks!
> * Is it possible to use TclHTTPD both as a proxy server and as a local
> web server at the same time? Again, a cookbook example piece of code
> would be appreciated.
>
> Thanks! --JYL
>
> _______________________________________________
> TclHttpd-users mailing list
> Tcl...@li...
> http://lists.sourceforge.net/mailman/listinfo/tclhttpd-users
>
> _______________________________________________
> TclHttpd-users mailing list
> Tcl...@li...
> http://lists.sourceforge.net/mailman/listinfo/tclhttpd-users

[Tclhttpd-users] Corrupted download tar file Tclhttpd?

[Erik L. <e.l...@hc...>]

L.S.

I downloaded the bundled distribution of TclHttpd3.2.1 from the web
site:

  http://dev.ajubasolutions.com/software/tclhttpd/


After doing:

        tar -xzvf Tclhttpd3.2.1-dist.tar.gz   ,

the file unpacked (lots of files), returning the output below after the
file ../../mac/bugs.doc had been extracted.

Has this been noticed by other users?

Can anyone tell me whether this is significant for the
functionality of the web server. 

Thanks for your attention,

Erik Leunissen.

*************************************************
skipped preceding messages of lots of files extracted (correctly);
error messages alone are shown below. 
*************************************************

tar: Skipping to next header

gzip: stdin: invalid compressed data--crc error

gzip: stdin: invalid compressed data--length error
tar: 117 garbage bytes ignored at end of archive
tar: Child returned status 1
tar: Error exit delayed from previous errors

end of error output
**********************************

RE: [Tclhttpd-users] Q: Using TclHTTPD as a proxy server?

[David L. <wh...@oz...>]

This might not be exactly a cookbook, but here it is fwiw.

The use of tclhttpd as a proxy server is a recurring question on the list.

Dave LeBlanc
****************************************************************

Subject: Proxy Server Using TCL (Please disregard previous post, forgot
non-binary group! =-)
From: lu...@pi...
Date: 1999/05/16
Newsgroups: comp.lang.tcl
I am assisting a good friend with this final project, which he needs
to graduate and I hope someone here can lend a little help if
possible. Included in this message below is a proxy server written in
TCL,
saved in text format. The question he's grappling with is:

Suppose your proxy were ALSO a server.  At what point or points in the
code (indicate the exact routine and line) would you branch to server
functionality?  Why?

I'm not familiar with TCL(neither is he) and he needs it by Tuesday in
order to graduate. =-( Hate to be a bother or anything, but if anyone
can help, please email me a response to:

lu...@pi...

If anything, I'm hoping this code will assist others with similar
projects, as sometimes stuff like this is tough to come by. =-)

Thanks...

#!/bin/sh
# the next line restarts using tclsh \
exec tclsh "$0" $@

#
# $Id: http_proxy.tcl,v 4.4 1997/01/30 00:01:19 dl Exp $
#
# An Privacy enhanced http proxy,
# initially based on my geturl2 raw WWW client and my tclhttpd
# (suitable for anonymous web access)
#
# Sample usage:
#    nohup http_proxy listeningport [nbrhops prox1 ... proxyn] >
/dev/null &
# if nbrhops and proxyI are provided,
# the proxy will generate a random route of nbrhops hops,
# amongst proxy 1...N   (nbrhops must be >= N)
#
# You can see/modify the parameters using your web browser, accessing
#   http://localhost:listeningport/admin
# To do this you shall define an APROXYPASS environement variable,
equal
# to the md5 digest/checksum of your password, for access to
# the proxy admin page (use 'md5sum "pass"' proc to get the value)
# For instance, to use the string 'passwd' as password, use :
# setenv APROXYPASS 76a2173be6393254e72ffa4d6df1030a
#
# NB: POST support and admin parameters modification is not yet
finished.
#
# You need a Binary tcl shell : tcl7.5 or later + tclbin +(and
optionally tclX)
# interp to use it
# ( tcl7.5 needed to listen to tcp port and clock, tclX for
lassign,etc
#  and tclbin for real binary IOs, md5 checksum/digest interface,...)
#
# To build this shell you need the tclbin distrib
# http://www.box.eu.org/~dl/tclbin.html and ftp://ftp.box.eu.org/tcl/
# C source files compressed tar file : tclbin-*.tgz  (currently v1.2)
#
# THIS IS A BETA RELEASE - PLEASE DON'T DISSEMINATE
#
# (c)1995 by Laurent Demailly - dl...@ww...
#            http://www.box.eu.org/~dl/
#
# Latest version shall always be available from
# http://www.box.eu.org/~dl/wwwtools.html
#
# (please send me feed back, comments, and tell me if you made
changes,...)
#
# ``Artistic'' license see LICENSE - Author: Laurent Demailly
#
# This program is free software; you can redistribute it and/or modify
# it under the terms and CONDITIONS of the included LICENSE
#
# If you don't have the LICENSE or need to clarify anything please
# contact the author
#
# This program is distributed in the hope that it will be useful,
# but WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
#
# $Log: http_proxy.tcl,v $
# Revision 4.4  1997/01/30 00:01:19  dl
# updated urls and emails. fix in 64ToStr.
#
# Revision 4.3  1996/05/08  13:41:04  dl
# fixed huge bug of unreturned buffer because notreadylock() was not
unset
#
# Revision 4.2  1996/05/02  22:39:03  dl
# missing -translation binary was causing garbage on binary files
#
# Revision 4.1  1996/05/02  21:58:44  dl
# Tcl(7.5) + tclbin only version (and optional tclX)
# no more tcldp.
# no 100% finished yet [the write blocking must be reimplemented
nicely]
#
# Revision 3.8  1996/04/22  18:54:47  dl
# added a lock for client waiting / close while waiting case
# typo/bugfix peer was not declared global in main handler
#
# Revision 3.7  1996/04/09  15:52:04  dl
# Don't send more bytes than "Content-Length" in request, even if
client does
#
# Revision 3.6  1996/04/09  15:32:01  dl
# added `small' POST requets support ! (which implied a binary read of
# headers/client too...)
# optional passing of Authorization* headers
#
# [old logs deleted for space sake]

# If you didn't "make install"
# copy libdlbin.sl to /usr/local/lib/tcl7.5
# and run
# echo 'pkg_mkIndex /usr/local/lib/tcl7.5 *[info sharedlibextension]'|
tclsh7.5
# or
#lappend auto_path .
# to test it in current directory

package require Bin;
package require Mdfive;

if [catch {package require Tclx} res] {
  puts "Running without tclX ($res) (using compat in tcl lib, a bit
slower)";
# Some minimal TclX replacements...
proc getclock {} {clock seconds}
proc lempty {lst} {regexp "\[ \t\n\]" $lst}

proc fmtclock {clockval {format {}} {zone {}}} {
    lappend cmd clock format $clockval
    if ![lempty $format] {
        lappend cmd -format $format
    }
    if ![lempty $zone] {
        lappend cmd -gmt 1
    }
    return [eval $cmd]
}
# simple one (no step/no continue...)
proc loop {var start end body} {
  upvar $var v;
  for {set v $start} {$v<$end} {incr v} {
    uplevel $body;
  }
}
proc lassign {list args} {
  set i 0;
  foreach vname $args {
    uplevel [list set $vname [lindex $list $i]];
    incr i;
  }
  lrange $list $i end
}
proc clength {str} {string length $str}
proc cequal {s1 s2} {expr [string compare $s1 $s2]==0}
# simple, we don't do "end"
proc crange {str first last} {string range $str [expr $first] [expr
$last]}
# tcl-usage' faq random :
proc random {args} {
  global RNG_seed;

  set max 259200;
  set argcnt [llength $args];
  if { $argcnt < 1 || $argcnt > 2 } {
    error "wrong # args: random limit | seed ?seedval?"
  }
  if ![string compare [lindex $args 0] seed] {
    if { $argcnt == 2 } {
      set RNG_seed [lindex $args 1]
    } else {
      set RNG_seed [clock clicks] ; # poor...
    }
    return;
  }
  if ![info exists RNG_seed] {
    set RNG_seed [clock clicks] ; # poor...
  }
  set RNG_seed [expr ($RNG_seed*7141+54773) % $max]
  return [expr int(double($RNG_seed)*[lindex $args 0]/$max)]
}
proc lvarpop {var} {
  upvar $var v;
  set r [lindex $v 0];
  set v [lrange $v 1 end];
  return $r;
}
}

#
# ---------- start of CONFIGURABLE section ----------

# max simultaneous proxy connections allowed
set maxconn 4
# absolute maximum (each proxy requires 2 connections)
set absmaxconn [expr 2*$maxconn];
# timeout in seconds for getting a query  (in milli-seconds)
set qtimeout 20000;
# timeout for the whole connect  (600000 = 10 mins)
set stimeout 120000 ; # two minutes is enough (we want to be fast)
# buffer size for one connection
set bufsz 32768 ;#16384; #8192


# set denied(aaa.bbb.ccc.ddd) 1;

# proc that is called for each connecting IP and shall return 0 for ok
# and 1 for denied.
proc access_forbid {host} {
  global denied;
# like this, unless host is found in the above 'denied' array, access
granted
# but this proc can be complexified at will to support any kind of
access ctrl
  info exists denied($host)
}

# ---------- end of configurable section ----------


# determine this server host and domain name :

# Note: on some OS/configs hostname is directly the fqhn
# (for me, not)
set hostname [lindex [split [exec hostname] .] 0];
# the running host full qualified name (host.domain name)
set fqhn [exec nslookup $hostname]
regexp "Name: +(\[^\n\]+)\n" $fqhn all fqhn;
# domain name alone
regexp {^([^\.]+)\.(.+)$} $fqhn all hn domain;
# (btw hn should be == hostname)

# record starting time
set dateup [fmtclock [getclock] "%d %h %Y %H:%M %Z" GMT];

#
# Buffer setup
#


# total buffer size
set bigbufsz [expr $bufsz*$maxconn];

bin_new bigbuf buffer $bigbufsz;
set freebuflst {};

loop i 0 $maxconn {
  # split the big buf in smaller shunks
  bin_new buf${i} buffer $bufsz bigbuf $i*$bufsz;
  bin_new buf${i}in  buffer $bufsz buf${i};
  bin_new buf${i}out buffer 0      buf${i};
  lappend freebuflst $i;
}

proc getfreebuf {} {
  global freebuflst;
  set res [lvarpop freebuflst]
  if {[cequal $res ""]} {error "no more bufs!"}
  return $res
}

proc givebackbuf {i} {
  global freebuflst;
  lappend freebuflst $i;
  global buf${i}in buf${i}out;
  bin_move -absolute buf${i}out 0;
  bin_move -absolute buf${i}in  0;
  global bufsz;
  bin_resize buf${i}in $bufsz;
}


# by default, only one routing
set autoroute {}
set nbrhops 0;
# by default, post is not allowed
#set allowpost 0;
set allowpost 1;

# allow authorization* headers ?
set allowauth 1;

# rcs kewords extraction
regexp {[.0-9]+} {$Revision: 4.4 $} version

# Proxy List keyword in http header:
set plistkeyw "ProxyControl";
# Protocol Version
set plistvers 1

# debug ?
set debug 2
if {[info exists env(DEBUG)]} {
  set debug $env(DEBUG);
  if {[catch {expr $debug>0}]} {set debug 0}
}

#
# proxy transfer handler, called when there is something to read
# on the socket server socket (copy it to the client):
#
proc trans_handler {cliconn mode servconn {recurs 0}} {
  global trkbytes debug;
#  puts "called trans_handler $cliconn $servconn $recurs";
  global bufid bufsz;
  set id $bufid($servconn);
  upvar buf${id}in  bufin ;
  upvar buf${id}out bufout ;

  if {[catch {bin_sizeof bufin} sz1]} {
    puts "hmmm error '$sz1' for id=$id, on
$cliconn,$servconn,$recurs";
    do_close $cliconn "error bufin!";
  }
  if {$sz1!=0} {
    if {[catch {set n [bin_read $servconn bufin]} res]} {
      set n 0;
if {$debug>=1} {
      puts "th $cliconn $servconn : got read error : $res";
}
    }
if {$debug>=3} {
    puts "th $cliconn $servconn : read $n/$sz1 bytes";
}
  } else {
    set n 0;
if {$debug>=3} {
    puts "th $cliconn $servconn : read buffer full, no read";
}
  }
  if {$n==0} {
    if {[bin_sizeof bufout]==0} {
      do_close $cliconn "transmit done (now $trkbytes kb)";
      return;
    }
  } else {
    bin_resize bufin $sz1-$n;
    set szi [bin_move bufin $n 1];
# we got a bug in the resize below... (should be fixed by the
notreadylock..)
#puts "trh c=$cliconn m=$mode s=$servconn r=$recurs
n=$n,sz1=$sz1,szi=$szi";
    if {[catch {bin_resize bufout $szi-[bin_move bufout 0]} msg]} {
      puts "error resize bufout: [bin_info bufout]";
      tkerror $msg;
    }
  }


  if {$recurs} {return $n}

#  if {[lempty [lindex [select {} $cliconn {} .2] 1]]}
#  global writable
#  set writable($cliconn) 0
#  fileevent $cliconn w "set writable($cliconn) 1";
#  puts "before vwait writable($cliconn)";
#  fileevent $servconn r {};
#  vwait writable($cliconn);
#  fileevent $servconn r "trans_handler $cliconn r $servconn";
#  puts "after  vwait writable($cliconn)";

  if {0} { # with tcl7.5 we can always write... (!)
    # not ready to write...
if {$debug>=3} {
    puts "th $cliconn $servconn : client not ready 1 for writing";
}
    fileevent $servconn r {};
    global notreadylock;
    set notreadylock($servconn) 1;
    update
    if {!$notreadylock($servconn)} {
      # socket have been closed in update, finish do_close' job
      givebackbuf $bufid($servconn);
      unset bufid($servconn);
      unset notreadylock($servconn);
      return ;
    }
    while {[lempty [lindex [select {} $cliconn {} .2] 1]]} {
if {$debug>=2} {
      puts "th $cliconn $servconn : client not ready n for writing";
}
      update;
      if {!$notreadylock($servconn)} {
        # socket have been closed in update, finish do_close' job
        givebackbuf $bufid($servconn);
        unset bufid($servconn);
        unset notreadylock($servconn);
        return ;
      }
      if {[uplevel #0 trans_handler $cliconn $mode $servconn 1]==0} {
        loop i 0 4 {
          after 250
          update
          if {!$notreadylock($servconn)} {
            # socket have been closed in update, finish do_close' job
            givebackbuf $bufid($servconn);
            unset bufid($servconn);
            unset notreadylock($servconn);
            return ;
          }
        }
      }
    }
    unset notreadylock($servconn);
    fileevent $servconn r "trans_handler $cliconn r $servconn";
  }

  set sz2 [bin_sizeof bufout];
  if {[catch {set p [bin_write - $cliconn bufout]} res]} {
    set p 0;
if {$debug>=1} {
    puts "th $cliconn $servconn : got a write error : $res";
}
  }
if {$debug>=3} {
  puts "th $cliconn $servconn : wrote $p/$sz2";
}
  bin_resize bufout $sz2-$p;
  if {$p==$sz2} {
# everything was read
#    puts "reset";
    bin_move -absolute bufout 0;
    bin_move -absolute bufin  0;
    bin_resize bufin $bufsz;
  } else {
    bin_move bufout $p 1;
  }
#  catch {flush $cliconn}
  set trkbytes [expr $trkbytes+$n/1024.];
#  puts "th $cliconn $servconn : transmitted $n bytes -> $trkbytes";
}

#
# usage / startup error
#
proc usage {msg} {
puts stderr "Error $msg";
puts stderr "Usage: [info script] port \[nbrhops proxy1 ...proxyN\]";
exit 1;
}


if {$argc==0} {usage "no port given!"};

lassign $argv port;
if {$argc==2} {usage "nbrhops given but no proxies!"};
if {$argc>2} {
  set nbrhops [lindex $argv 1];
  set autoroute [lrange $argv 2 $argc];
  set lg [llength $autoroute];
  if {[catch {expr $nbrhops>$lg} res]} {usage "nbrhops is not a
number!"};
  if {$res} {usage "nbrhops > number of proxies given!"};
};


# listen on port
set srv [socket -server newconn $port]
# init counters and stat:
set nbrconn 0;
set count 0;
set pcount 0;
set trkbytes 0.0;

# connect handler:
puts stderr "listening on host $fqhn ($hostname,$domain) on port
$port";
puts stderr "nbrhops=$nbrhops, autoroute=($autoroute)";

# accept connects:
proc newconn {socket host port} {
  global count absmaxconn nbrconn qtimeout time queue ql debug;
  set ts [getclock];
if {$debug>=1} {
  puts "C $ts ($nbrconn,$count) $host -> $socket";
}
  incr count;
  if {[access_forbid $host]} {
if {$debug>=0} {
    puts "denied $host";
}
    catch {close $socket};
    return
  }
  incr nbrconn;
#  dp_socketOption $socket sendBuffer 16384;
  fconfigure $socket -blocking no -translation binary;
#  dp_socketOption $socket keepalive yes;
  if {$nbrconn>$absmaxconn} {
     toobusy $socket "Too many connections ($nbrconn), reload in few
moments"
     return;
  };
  set time($socket) $ts;
  set queue($socket) {};
  set ql($socket) 0;
  fileevent $socket r "handler $host r $socket";
  after $qtimeout "qtimeout $socket $ts"
}

proc qtimeout {file ts} {
  global time;
  #puts "called timeout $file $ts";
  if {[info exists time($file)]} {
    #puts "times($file)=$times($file)";
    if {$time($file)==$ts} {
      serror $file "Received no valid query" 408 "Request Timeout";
    }
  }
}

proc stimeout {file ts} {
  global time;
  #puts "called timeout $file $ts";
  if {[info exists time($file)]} {
    #puts "times($file)=$times($file)";
    if {$time($file)==$ts} {
      do_close $file "session too long";
    }
  }
}


# read buffer
bin_new buffer buffer 16384;
bin_new bufptr buffer 0 buffer;
bin_new bufrst buffer 0 buffer;

# Main connection handler
# determines what is requested and what to call for answer
#
proc handler {host mode file} {
  global peer time queue ql plistkeyw plistvers debug \
     fqhn hostname domain port nbrhops autoroute allowpost allowauth;
  set what {};
  global buffer bufptr bufrst;
  if {[catch {bin_read $file buffer} lg]} {
    do_close $file "read error '$lg'";
    return;
  }
#  puts "called handler $file : read '$what'";
  if {$lg==0} {do_close $file "eof"; return}
  if {[info exists peer($file)]} {return}; #ignore what client says
after conn
  bin_resize bufptr $lg;
  set what $bufptr(_str_);
  regsub -all {\\.} $what {\\} what; # so [clength $what] is r
  # (side effect: if there are '\0' in headers (which is illegal),
  # they'll appear as '\')
  append queue($file) $what;
  # header is fully here ? (if not we just wait)
  if {![regexp -indices "\r?\n\r?\n" $queue($file) idx]} {
    if {($ql($file)+$lg)>1024} {
      serror $file "" 400 "Query too long"
    } else {
      incr ql($file) $lg;
    }
    return;
  }
  # cool, we found the header separation
  lassign $idx p1 p2;
  set rest [expr $lg-($p2+1-$ql($file))];
  bin_resize bufrst $rest;
  if {$rest!=0} {
    bin_move -absolute bufrst $lg-$rest 1;
if {$debug>=4} {
  puts "remaining $rest bytes! ($bufrst(_str_))";
}
  }
  set what [crange $queue($file) 0 $p1-1];
  regsub -all "\r" $what {} what;
  if {![regexp \
"^(\[^ \n\]+) (\[^ \n\]+) HTTP/1.0(\n(.+\n)?($plistkeyw: V(\[0-9\]+)
?(\[^\n\]*))\n)?"\
   $what gall method url r1 r2 apline apvers aplist]} {
    # wrong command... problem
    serror $file \
           "Format unrecognized:\n<pre>\n[txt2html $what]</pre>" \
           400 "Bad Request";
    return;
  }
  if {![regexp {^(GET|HEAD|POST)$} $method]} {
    # not implemented method
    serror $file \
      "Sorry, the method <strong>$method</strong> is not
implemented.\n\
      <p>Your query was\n<pre>\n[txt2html $what]</pre>" \
      501 "Not Implemented ($method)";
    return;
  }
  # if a local url is requested, skip proxying it :
  if {[regsub -nocase
"^http://($fqhn|$hostname|localhost(\.$domain)?|127\.0\.0\.1):$port/"
$url / url]} {
if {$debug>=3} {
    puts "url found to be local ($url)"
}
  }
  # Do we want full thing or headers only?
  set getflag [expr ![cequal $method "HEAD"]];
  set postflag [cequal $method "POST"];
  set moreheaders {};
  set contentLG 0;
  if {$postflag} {
    # get and check content-length
    set contentLG 0;
    regexp -nocase {Content-length: *([0-9]+)} $what all contentLG;
    if {$contentLG>$rest} {
      serror $file "I can't handle this post request because\
\nYou have to send $contentLG bytes and I've read only $rest bytes..."
\
      500 "Can't handle this Post $rest/$contentLG";
      return;
    }
    if {$contentLG>0} {bin_resize bufrst $contentLG}
    # extract/save all Content-* headers
    set all $what;
    while {[regexp -nocase "\n(Content-\[^\n\]+)(.*)$" $all a ct all]}
{lappend moreheaders $ct}
  }
  if {$allowauth} {
    set all $what;
    while {[regexp -nocase "\n(Authorization\[^\n\]+)(.*)$" $all a ct
all]} {lappend moreheaders $ct}
  }
  if {$debug>5} {puts "content=($moreheaders), contentLG=$contentLG"}
  switch -regexp -- $url {
      {^/admin}   {
        if {[regexp -nocase "\nAuthorization: +Basic +(\[^\n\]+)" \
                    $what all auth]} {
          set user "";
          set pass "";
          regexp {^([^:]+):(.+)$} [64ToStr $auth] all user pass;
          if {[admincheck $host $user $pass]} {
            serror $file "Bad host/user/passwd" 401 \
              "Unauthorized" "WWW-Authenticate: Basic
realm=\"admin\"\n";
          } else {
            admin $file $getflag $host $user $pass;
          }
        } else {
          serror $file "You need an authorisation capable browser to
access" \
            401 "Unauthorized" "WWW-Authenticate: Basic
realm=\"admin\"\n";
        }
      }
      {^/source} {sendsource     $file $getflag}
      {^/}       {sendserverinfo $file $getflag [txt2html
$queue($file)]}
      default {
        if {$postflag && !$allowpost} {
          serror $file "POST is disabled.\n\
          <p>Your query was\n<pre>\n[txt2html $queue($file)]</pre>" \
          403 "Forbidden";
          return;
        }
        # real proxy job:
        # parse the url :
        if {![regexp {^http://([^/:]+)(:([0-9]+))?(/[^#]*)?(#.*)?$}
$url \
                     all dhost p dport what key]} {
            # for instance port must be numerical
if {$debug>=2} {
        puts "invalid url='$url' ($queue($file))";
}
            serror $file "<pre>$url</pre>" 400 "Invalid Proxy URL";
            return;
          }
        if {[cequal $dport ""]} {set dport 80}
        if {[cequal $what ""]} {set what "/"}
# port checking #1/2 :
        if {$dport<1024 && $dport!=80} {serror $file "Illegal dest.
port $dport" 403 "Forbidden"; return}
        set apflag [expr [cequal $apline ""]==0];
if {$debug>=1} {
        puts "$file -> proxying $method http://$dhost:$dport$what
($apline)";
}
        if {$apflag} {
          if {([catch {expr $apvers!=$plistvers} res] || $res)} {
           serror $file "<pre>$apline</pre>" 500 "Invalid Proxy Ctrl
Version";
           return;
          }
          if {[catch {llength $aplist} lg]} {
           serror $file "<pre>$aplist</pre>" 400 "Invalid Proxy List";
           return;
          }
        } else {
          if {$nbrhops!=0} {
            # generate a random proxy route, choosen in autoroute
            set aplist [random_path $nbrhops $autoroute [llength
$autoroute]];
            set lg [llength $aplist];
if {$debug>=1} {
            puts "generated random path ($aplist)";
}
          } else {set lg 0}
        }
        if {$lg>=1} {
          set thisproxy [lindex $aplist 0];
          set restproxy [lrange $aplist 1 $lg];
          if {![regexp {^(.+):([0-9]+)$} $thisproxy all phost pport]}
{
            serror $file "<pre>$thisproxy</pre>" 400 "Invalid Next
Proxy Entry";
            return;
          }
          lappend moreheaders "$plistkeyw: V$plistvers $restproxy";
# port checking #2/2 :
          if {$pport<1024 && $pport!=80} {serror $file "Illegal proxy
port $pport" 403 "Forbidden"; return}
          do_query $file $method $phost $pport \
             "http://$dhost:$dport$what" [join $moreheaders \r\n]
$contentLG;
        } else {
          lappend moreheaders $apline;
          do_query $file $method $dhost $dport $what [join
$moreheaders \r\n] $contentLG;
        }
      }
    }
}

proc random_path {n list lg} {
 set idx [random $lg]
 if {$n>1} {
   incr n -1;
   incr lg -1;
   return "[lindex $list $idx] [random_path $n [lreplace $list $idx
$idx] $lg]"
 } else {
   return "[lindex $list $idx]"
 }
}

proc txt2html {str} {
regsub -all "&" $str {\&amp;} str;
regsub -all "<" $str {\&lt;} str;
regsub -all ">" $str {\&gt;} str;
regsub -all \" $str {\&quot;} str;
return $str;
}

proc toobusy {file msg} {
  serror $file "$msg\n<p>Try to <b>reload</b> in a moment" 503
"Service Overloaded" \
             "Retry-After: 15\n";
}

proc serror {file msg {id 500} {title "Error"} {more ""}} {
  global version fqhn port;
  catch {
    puts $file "HTTP/1.0 $id $title
Server: tclProxy/dl$version
Content-Type: text/html
$more
<HEAD><TITLE>$title</TITLE>
<link rev=\"made\" href=\"mailto:ld...@ma...\">
</HEAD>
<BODY>
<H1>$title</H1>
$msg
<HR>
<ADDRESS>
<A HREF=\"http://$fqhn:$port\">
Anonymous proxy httpd</a> v$version server in tcl, by
<A HREF=\"http://www.box.eu.org/~dl/\">dl</A>
</ADDRESS>
</BODY>"
  }
  do_close $file "error ($id $title)";
}

proc htmlblah {file getflag title msg} {
  global version;
   set sendstr "<HEAD><TITLE>$title</TITLE>
<link rev=\"made\" href=\"mailto:ld...@ma...\">
</HEAD>
<BODY>
<H1>$title</H1>
$msg
<HR>
<ADDRESS>
<A HREF=\"http://www.box.eu.org/~dl/wwwtools.html\">
Anonymous proxy httpd</a> v$version server in tcl,
<A HREF=\"http://www.box.eu.org/~dl/disclaimer.html\">&copy;</A>
 by
<A HREF=\"http://www.box.eu.org/~dl/\">dl</A>
</ADDRESS>
</BODY>
"
  set sl  [clength $sendstr];
  set chk [md5sum  $sendstr];
  catch {
    puts $file "HTTP/1.0 200 Document follows
Server: tclProxy/dl$version
Content-Type: text/html
Content-Length: $sl
Content-Digest: MD5=$chk
"
  flush $file;
  if $getflag {puts -nonewline $file $sendstr}
  }
  do_close $file "htmlblah $getflag ($title)";
}

proc sendserverinfo {file getflag what} {
  global nbrconn absmaxconn count pcount dateup trkbytes fqhn port
freebuflst;
        htmlblah $file $getflag "Anonymous Proxy HTTP Server" "
Welcome on this experimental WWW proxy server, feel free to use it
(but not
abuse it, <b>please</b>), source is
<a href=\"/source\">here</a> and latest version and informations are
on
<a href=\"http://www.box.eu.org/~dl/wwwtools.html\">
http://www.box.eu.org/~dl/wwwtools.html</a>.<p>
Use <tt>setenv http_proxy http://$fqhn:$port/</tt> to use it, or
better, run
a local copy and join the privacy http proxy network.
<p>
Access restricted <a href=\"http://localhost:$port/admin\">proxy
admin</a>.
<p>
Look at the amount of information <em>your</em> browser is sending
(and this
proxy is throwing away) :<br>
See for instance the <a href=\"refered\">Referer:</a> that might
contain
very personal informations (back links).
(Not all browsers put a Referer field, though)
<pre>
$what</pre>
<p>
Currently: $nbrconn/$absmaxconn open connections,<br>
Free buffers: $freebuflst<br>
Served a total of $count requests since $dateup<br>
Proxy requests: $pcount, transmitted [format %.1f $trkbytes] kbytes"
}
#
# Closing proc
#
proc do_close {file msg} {
  global nbrconn time queue ql peer bufid debug;
if {$debug>=1} {
  puts "closing $file ($msg)"; flush stdout;
}
  catch {fileevent $file r {} }
  catch {unset time($file)}
  catch {unset queue($file)}
  catch {unset ql($file)}
  global notreadylock;
  if {[info exists bufid($file)]} {
    if {[info exists notreadylock($file)]} {
      set notreadylock($file) 0; # raise flag so it can given back
later...
    } else {
      givebackbuf $bufid($file);
      unset bufid($file);
    }
  }
  if {[info exists peer($file)]} {
    set mypeer $peer($file);
    unset peer($file);
    if {[info exists time($mypeer)]} {do_close $mypeer "peer $msg"}
  }
#  catch {flush $file}
  catch {close $file}
  incr nbrconn -1;
}

proc do_query {file method host port what apline contentLG} {
global peer bufid time stimeout version count pcount conn nbrconn
debug;
# connect to the host
if {[catch {set socket [socket $host $port]} msg]} {
  puts stderr "connect on $host port $port : $msg";
  serror $file "Connect error on $host port $port : $msg" 404 "Not
found";
  return;
}
# dp_filehandler $file; #ignore what client migh say now
# (in fact not, lets detect close)

fconfigure $socket -blocking no -translation binary;
#dp_socketOption $socket keepalive yes;
set ts [getclock]
if {$debug>=1} {
puts "S $ts ($nbrconn,$count) $host:$port -> $socket";
}
set time($socket) $ts;
set time($file) -$ts;
set peer($file) $socket;
set peer($socket) $file;
incr count;
incr pcount;
incr nbrconn;
if {[catch getfreebuf res]} {
     toobusy $file "Too many connections ($nbrconn) ($res), reload in
few moments"
     return;
}
set bufid($socket) $res;
after $stimeout "stimeout $socket $ts"
#puts "Sending $method $what to $host:$port"
# send the httpd query :
if {![cequal $apline ""]} {set more "\n$apline\r"} else {set more ""}
set what "$method $what HTTP/1.0\r$more
User-Agent: tclproxy/dl$version
(http://www.box.eu.org/~dl/wwwtools.html)\r
Accept: */*\r
\r\n"
set lg [string length $what];
bin_new query buffer $lg;
regsub -all {\\} $what {\\\\} what;
set query(_str_) $what;
set wrote [bin_write $socket query];
if {$wrote<$lg} {puts "probable error on $socket : $wrote<$lg"}
if {$contentLG>0} {
  global bufrst;
  set contentWR [bin_write $socket bufrst];
  if {$contentWR<$contentLG} {puts "probable post error on $socket :
$contentWR<$contentLG"} elseif {$debug>=3} {
  puts "sent request&post data ($wrote+$contentWR bytes) on $socket"
  }
} elseif {$debug>=3} {
  puts "sent request ($wrote bytes) on $socket"
}
if [catch {flush $socket} msg] {puts "flushing error $msg"}
fileevent $socket r "trans_handler $file r $socket";
}

# *** WWW utilities extracted from my other stuff :

# *** base64.tcl

# authorisation mecanism
# Base64 <-> String  Translation, in TclX,
# 9/1995 by Laurent Demailly - ld...@ma... -
http://www.box.eu.org/~dl/
# Free Software - No warranty

set _pad "="
set _base64 \
  "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/"

# encode a tcl string using base64 mime like coding
proc StrTo64 {bin} {
  global _pad _base64;
  set lg [clength $bin]
  set res {};
  loop i 2 $lg 3 {
    scan [crange $bin $i-2 $i] %c%c%c a b c;
    append res [cindex $_base64 [expr $a>>2]];
    append res [cindex $_base64 [expr (($a&03)<<4) | ($b>>4)]];
    append res [cindex $_base64 [expr (($b&017)<<2)| ($c>>6)]];
    append res [cindex $_base64 [expr  ($c&077)]];
  }
  if {$lg%3} {
    set b 0;
    scan [crange $bin $i-2 $i] %c%c a b;
    append res [cindex $_base64 [expr $a>>2]];
    append res [cindex $_base64 [expr (($a&03)<<4) | ($b>>4)]];
    if {$lg%3==1} {
      append res $_pad$_pad;
    } else {
      append res [cindex $_base64 [expr ($b&017)<<2]];
      append res $_pad;
    }
  }
  return $res;
}

# restore string that was base64 encoded. If there are encoded '\0'
they
# will simply be skipped
proc 64ToStr {coded} {
  global _base64 _pad;
  set lg [clength $coded];
  if {$lg%4} {error "Invalid length $lg for a base 64 encoded string"}
  set res {};
  loop i 0 $lg 4 {
    loop j 0 4 {
      set c [cindex $coded $i+$j];
      set n$j [string first $c $_base64];
# comment out /remove the sanity tests below for better performance:
      if \$n$j==-1 {
        if {[cequal $c $_pad]} {
          if {$i+$j<$lg-2} {
            error "illegal padding char early in base64 coded string"
          }
        } else {
          error "illegal char '$c' for a base64 coded string"
        }
      }
    }
    append res [format %c [expr ($n0<<2)+($n1>>4)]];
    if $n2==-1 {
      if $n3!=-1 {
        error "last char is not pad while the one before is ('$_pad')"
      }
    } else {
      append res [format %c [expr (($n1 & 0xf)<<4)+($n2>>2)]]
      if $n3!=-1 {append res [format %c [expr (($n2 & 3)<<6)+$n3]]}
    }
  }
  return $res;
}

# *** uncgi.tcl

# from UnCgi Translation hack, in Tcl, v1.5 5/1995 by
dl...@ww...
proc uncgi {buf} {
regsub -all {\\(.)} $buf {\1} buf ;
regsub -all {\\} $buf {\\\\} buf ;
regsub -all { }  $buf {\ } buf ;
regsub -all {\+} $buf {\ } buf ;
regsub -all {\$} $buf {\$} buf ;
regsub -all \n   $buf {\n} buf ;
regsub -all {;}  $buf {\;} buf ;
regsub -all {\[} $buf {\[} buf ;
regsub -all \" $buf \\\" buf ;
regsub  ^\{ $buf \\\{ buf ;
regsub -all -nocase {%([a-fA-F0-9][a-fA-F0-9])} $buf {[format %c
0x\1]} buf
eval return \"$buf\"
}

# *** parse cgi message

# returns in the 'cgi' array all the parameters sent to the script
# through 'message' (each array cell is a list (ie if only one value
# is expected through 'test' variable, use [lindex $cgi(test) 0] to
get it)).
proc parse_cgi_message {message} {
global cgi;
set cgi() "";
foreach pair [split $message &] {
  set plst [split $pair =];
  set name [uncgi [lindex $plst 0]];
  set val  [uncgi [lindex $plst 1]];
  lappend cgi($name) $val;
}
}

# *** end of included utilities

# Admin Check access
proc admincheck {host user pass} {
  global debug;
if {$debug>=2} {
  puts "A $user@$host"
}
  # because passwd are sent almost clear, allow only localhost
connects:
  if {![cequal $host 127.0.0.1]} {return 1}
  # (note that it is only because the proxy strips headers that it
can't
  #  be used against itself to 'appear' from localhost)

  # using running name as user  (this is not a secret !)
  global env;
  if {![cequal $user $env(LOGNAME)]} {return 1}
  # passcheck, using md5 digest
  if {![info exists env(APROXYPASS)]} {
    puts "APROXYPASS env var not defined!";
    return 1;
  }
  if {![cequal [md5sum $pass] $env(APROXYPASS)]} {return 1}
  return 0; # access granted
}

proc md5sum {what} {
  bin_new d digest 16;
  bin_new w object [clength $what];
  regsub -all {\\} $what {\\\\} what;
  set w(_str_) $what;
  md5 d w;
  return $d(_hex_);
}

proc admin {file getflag host user pass} {
  global nbrconn absmaxconn count pcount dateup trkbytes fqhn port
freebuflst \
         nbrhops autoroute allowpost;
  htmlblah $file $getflag "Proxy HTTP Server Admin" \
        "Welcome $user, from $host on the WWW proxy server
administration page
<p>
<form action=\"/debug\" method=\"Post\">
Number of hops (must be &lt;= number of proxies in the route list):
 <input name=\"nbrhops\" value=\"$nbrhops\" size=3><p>
Proxy route list (each proxy as host:port):<br>
<input name=\"autoroute\" value=\"$autoroute\"
size=[expr [clength $autoroute]+15]><p>
Allow Post:
<input type=\"checkbox\" name=\"post\" [if $allowpost {set res
CHECKED}]><p>
<input type=\"submit\" value=\"Change! (Not yet working)\">
</form>
<p>
Currently: $nbrconn/$absmaxconn open connections,<br>
Free buffers: $freebuflst<br>
Served a total of $count requests since $dateup<br>
Proxy requests: $pcount, transmitted [format %.1f $trkbytes] kbytes
<p>
<a href=\"/\">Back to server root</a>
"
}

# store the source
set sname [info script]
set fic [open $sname]
set source  [read $fic]
set slength [clength $source]
set schk    [md5sum  $source]
close $fic;

proc sendsource {file getflag} {
  global source slength schk version;
# we have to increase the buffer so we can write the whole source in
# a single puts
  fconfigure $file -buffersize 32768;
  catch {
    set title "Document follows"
    puts $file "HTTP/1.0 200 Document follows
Server: tclProxy/dl$version (infos on
http://www.box.eu.org/~dl/wwwtools.html)
Content-Type: text/plain
Content-Length: $slength
Content-Digest: MD5=$schk
"
   flush $file;
   if $getflag {puts -nonewline $file $source}
  }
  do_close $file "source sent";
}

set version "${version}d${debug}"

# background error handler (exit with trace output)
proc tkerror {mess} {
global errorInfo;
puts stderr "BACKGROUND ERROR : $mess";
puts stderr "ERRORINFO: $errorInfo";
exit 0;
}

set errorInfo {};


puts "sourced ok"
vwait forever;
#EOF


(end of original message)
----------------------------------------------------------------------------
--

You can view this message and the related discussion by following this link:
http://www.deja.com/%5bST_rn%3dap%5d/dnquery.xp?search=thread&svcclass=dnser
ver&recnum=%3c3...@ne...%3e%231/8
We hope to see you soon at Deja.com.
Before you buy.
http://www.deja.com/%5bST_rn%3dap%5d/



-----Original Message-----
From: tcl...@li...
[mailto:tcl...@li...]On Behalf Of Jacob
Levy
Sent: Saturday, December 02, 2000 10:57 AM
To: tcl...@li...
Subject: [Tclhttpd-users] Q: Using TclHTTPD as a proxy server?


Two questions:

* Is it possible to use TclHTTPD as a proxy server? If so, how? A
cookbook explanation would be nice. Thanks!
* Is it possible to use TclHTTPD both as a proxy server and as a local
web server at the same time? Again, a cookbook example piece of code
would be appreciated.

Thanks! --JYL


_______________________________________________
TclHttpd-users mailing list
Tcl...@li...
http://lists.sourceforge.net/mailman/listinfo/tclhttpd-users

[Tclhttpd-users] Q: Using TclHTTPD as a proxy server?

[Jacob L. <jy...@be...>]

Two questions:

* Is it possible to use TclHTTPD as a proxy server? If so, how? A
cookbook explanation would be nice. Thanks!
* Is it possible to use TclHTTPD both as a proxy server and as a local
web server at the same time? Again, a cookbook example piece of code
would be appreciated.

Thanks! --JYL

Re: [Tclhttpd-users] CGI.pm -- vs -- TclHttpd?

[Brent W. <bre...@in...>]

The "bug" is a difference in the way one of the environment
variables is created - I think it is REQUEST_URI
You should run a CGI that dumps the environment in TclHttpd and
then compare the same results on an Apache server.

>>>Robert Withrow said:
 > Did the interoperability problem between CGI.pm and TclHttpd ever
 > get resolved?
 > 
 > To re-cap the issue:
 > 
 > I'm trying to use faq-o-matic 
 > 
 > (http://www.dartmouth.edu/~jonh/ff-serve/cache/1.html)
 > 
 > with tcl-httpd, but I get malformed urls from 
 > it.  It works fine from apache.
 > 
 > The problem is that all URLs it generates (from forms
 > or whatever) have the initial part of the URL prepended.
 > 
 > For example, if I start it with http://www.xxx.com/cgi-bin/fom.cgi,
 > I'll get urls like this:
 > 
 > http://www.xxx.comhttp://www.xxx.com/cgi-bin/fom.cgi?cmd=install&step=&tempp
     ass=xyzzy&Submit=Submit
 > 
 > I've narrowed this down to the Perl CGI library.  Here is a
 > test CGI:
 > 
 >   #!/usr/local/bin/perl
 > 
 >   use CGI qw/:standard/;
 > 
 >   $cgi = new CGI;
 >   $cgiUrl = $cgi->url();
 > 
 >   print header;
 >   print start_html('CGI->url bug demo');
 >   print h2("CGI version: ".$CGI::VERSION);
 >   print h2("CGI->url(): ".$cgiUrl);
 >   print end_html;
 > 
 > On tclhttpd I get:
 > 
 >   CGI version: 2.56
 >   CGI->url(): http://www.xxx.comhttp://www.xxx.com/cgi-bin/cgitest.cgi
 > 
 > On Apache I get:
 > 
 >   CGI version: 2.56
 >   CGI->url(): http://www.xxx.com/bcc/cgi-bin/cgitest.cgi
 > 
 > Any ideas why?  Is is just me?
 > 
 > -- 
 > Robert Withrow -- (+1 978 288 8256)
 > BWi...@Ba...
 > 
 > _______________________________________________
 > TclHttpd-users mailing list
 > Tcl...@li...
 > http://lists.sourceforge.net/mailman/listinfo/tclhttpd-users

--	Brent Welch	<bre...@in...>
	http://www.interwoven.com

[Tclhttpd-users] CGI.pm -- vs -- TclHttpd?

[Robert W. <bwi...@no...>]

Did the interoperability problem between CGI.pm and TclHttpd ever
get resolved?

To re-cap the issue:

I'm trying to use faq-o-matic 

(http://www.dartmouth.edu/~jonh/ff-serve/cache/1.html)

with tcl-httpd, but I get malformed urls from 
it.  It works fine from apache.

The problem is that all URLs it generates (from forms
or whatever) have the initial part of the URL prepended.

For example, if I start it with http://www.xxx.com/cgi-bin/fom.cgi,
I'll get urls like this:

http://www.xxx.comhttp://www.xxx.com/cgi-bin/fom.cgi?cmd=install&step=&temppass=xyzzy&Submit=Submit

I've narrowed this down to the Perl CGI library.  Here is a
test CGI:

  #!/usr/local/bin/perl

  use CGI qw/:standard/;

  $cgi = new CGI;
  $cgiUrl = $cgi->url();

  print header;
  print start_html('CGI->url bug demo');
  print h2("CGI version: ".$CGI::VERSION);
  print h2("CGI->url(): ".$cgiUrl);
  print end_html;

On tclhttpd I get:

  CGI version: 2.56
  CGI->url(): http://www.xxx.comhttp://www.xxx.com/cgi-bin/cgitest.cgi

On Apache I get:

  CGI version: 2.56
  CGI->url(): http://www.xxx.com/bcc/cgi-bin/cgitest.cgi

Any ideas why?  Is is just me?

-- 
Robert Withrow -- (+1 978 288 8256)
BWi...@Ba...

[Tclhttpd-users] Some CVS updates to tclhttpd

[Brent W. <bre...@in...>]

Thanks to some patches and bug reports, I've made a few fixes
and committed them to the SF CVS repository.  If I'm giving out
credit incorrectly, let me know.

        * bin/httpd.tcl: Fixed setting of auto_path in the standard
        install configuration so that the limit and crypt packages can
        be found (Peter Farmer)
        * lib/doc.tcl: Added Doc_RegisterRoot so the cgi domain can set up
        the directory mapping used by DocAccessHook. (Peter Summers)
        * lib/cgi.tcl: Fixed "extra timer" bug found by Petrus that could cause
        erroneous aborts of CGI connections. (Petrus Vloet)
        Added use of Doc_RegisterRoot so DocAccessHook works right for
        /cgi-bin directories outside the htdocs hierarchy.  (Peter Summers)
        Eliminated extra / build-up in /cgi/bin pathnames (Peter Summers)

--	Brent Welch	<bre...@in...>
	http://www.interwoven.com