The R Project SVN R

Rev

Rev 26421 | Blame | Compare with Previous | Last modification | View Log | Download | RSS feed 

/*
 *  R : A Computer Language for Statistical Data Analysis
 *  Copyright (C) 2000-3   The R Development Core Team.
 *
 *  This program is free software; you can redistribute it and/or modify
 *  it under the terms of the GNU General Public License as published by
 *  the Free Software Foundation; either version 2 of the License, or
 *  (at your option) any later version.
 *
 *  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.  See the
 *  GNU General Public License for more details.
 *
 *  You should have received a copy of the GNU General Public License
 *  along with this program; if not, write to the Free Software
 *  Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
 */

#ifdef HAVE_CONFIG_H
#include <config.h>
#endif

#include <Defn.h>
#include <Fileio.h>
#include <Rconnections.h>
#include <R_ext/R-ftp-http.h>

static void *in_R_HTTPOpen(const char *url, const int cacheOK);
static int   in_R_HTTPRead(void *ctx, char *dest, int len);
static void  in_R_HTTPClose(void *ctx);

static void *in_R_FTPOpen(const char *url);
static int   in_R_FTPRead(void *ctx, char *dest, int len);
static void  in_R_FTPClose(void *ctx);


#include <R_ext/Rinternet.h>

#ifdef HAVE_UNISTD_H
# include <unistd.h>
#endif

#ifdef HAVE_FCNTL_H
# include <fcntl.h>
#endif

/* ------------------- internet access functions  --------------------- */

#if defined(USE_WININET_ASYNC) && !defined(USE_WININET)
#define USE_WININET 2
#endif

static Rboolean IDquiet=TRUE;

static Rboolean url_open(Rconnection con)
{
    void *ctxt;
    char *url = con->description;
    UrlScheme type = ((Rurlconn)(con->private))->type;

    if(con->mode[0] != 'r') {
    REprintf("can only open URLs for reading");
    return FALSE;
    }

    switch(type) {
    case HTTPsh:
    ctxt = in_R_HTTPOpen(url, 0);
    if(ctxt == NULL) {
      /* if we call error() we get a connection leak*/
      /* so do_url has to raise the error*/
      /* error("cannot open URL `%s'", url); */
        return FALSE;
    }
    ((Rurlconn)(con->private))->ctxt = ctxt;
    break;
    case FTPsh:
    ctxt = in_R_FTPOpen(url);
    if(ctxt == NULL) {
      /* if we call error() we get a connection leak*/
      /* so do_url has to raise the error*/
      /* error("cannot open URL `%s'", url); */
        return FALSE;
    }
    ((Rurlconn)(con->private))->ctxt = ctxt;
    break;
    default:
    warning("unknown URL scheme");
    return FALSE;
    }

    con->isopen = TRUE;
    con->canwrite = (con->mode[0] == 'w' || con->mode[0] == 'a');
    con->canread = !con->canwrite;
    if(strlen(con->mode) >= 2 && con->mode[1] == 'b') con->text = FALSE;
    else con->text = TRUE;
    con->save = -1000;
    return TRUE;
}

static void url_close(Rconnection con)
{
    UrlScheme type = ((Rurlconn)(con->private))->type;
    switch(type) {
    case HTTPsh:
    in_R_HTTPClose(((Rurlconn)(con->private))->ctxt);
    break;
    case FTPsh:
    in_R_FTPClose(((Rurlconn)(con->private))->ctxt);
    break;
    }
    con->isopen = FALSE;
}

static int url_fgetc(Rconnection con)
{
    UrlScheme type = ((Rurlconn)(con->private))->type;
    void * ctxt = ((Rurlconn)(con->private))->ctxt;
    unsigned char c;
    size_t n = 0; /* -Wall */

    switch(type) {
    case HTTPsh:
    n = in_R_HTTPRead(ctxt, (char *)&c, 1);
    break;
    case FTPsh:
    n = in_R_FTPRead(ctxt, (char *)&c, 1);
    break;
    }
    return (n == 1) ? c : R_EOF;
}

static size_t url_read(void *ptr, size_t size, size_t nitems,
               Rconnection con)
{
    UrlScheme type = ((Rurlconn)(con->private))->type;
    void * ctxt = ((Rurlconn)(con->private))->ctxt;
    size_t n = 0; /* -Wall */

    switch(type) {
    case HTTPsh:
    n = in_R_HTTPRead(ctxt, ptr, size*nitems);
    break;
    case FTPsh:
    n = in_R_FTPRead(ctxt, ptr, size*nitems);
    break;
    }
    return n/size;
}


static Rconnection in_R_newurl(char *description, char *mode)
{
    Rconnection new;

    new = (Rconnection) malloc(sizeof(struct Rconn));
    if(!new) error("allocation of url connection failed");
    new->class = (char *) malloc(strlen("file") + 1);
    if(!new->class) {
    free(new);
    error("allocation of url connection failed");
    }
    strcpy(new->class, "url");
    new->description = (char *) malloc(strlen(description) + 1);
    if(!new->description) {
    free(new->class); free(new);
    error("allocation of url connection failed");
    }
    init_con(new, description, mode);
    new->canwrite = FALSE;
    new->open = &url_open;
    new->close = &url_close;
    new->fgetc = &url_fgetc;
    new->read = &url_read;
    new->private = (void *) malloc(sizeof(struct urlconn));
    if(!new->private) {
    free(new->description); free(new->class); free(new);
    error("allocation of url connection failed");
    }

    IDquiet = TRUE;
    return new;
}



#ifndef Win32
static void putdots(int *pold, int new)
{
    int i, old = *pold;
    *pold = new;
    for(i = old; i < new; i++) {
    REprintf(".");
    if((i+1) % 50 == 0) REprintf("\n");
    else if((i+1) % 10 == 0) REprintf(" ");
    }
    if(R_Consolefile) fflush(R_Consolefile);
}
#endif

/* note, ALL the possible structures have the first two elements */
typedef struct {
    int length;
    char *type;
    void *ctxt;
} inetconn;

#ifdef Win32
#include <graphapp/ga.h>
#endif

/* download(url, destfile, quiet, mode, cacheOK) */

#define CPBUFSIZE 65536
#define IBUFSIZE 4096
static SEXP in_do_download(SEXP call, SEXP op, SEXP args, SEXP env)
{
    SEXP ans, scmd, sfile, smode;
    char *url, *file, *mode;
    int quiet, status = 0, cacheOK;
#ifdef Win32
    window wprog;
    progressbar pb;
    label l_url;
#endif


    checkArity(op, args);
    scmd = CAR(args); args = CDR(args);
    if(!isString(scmd) || length(scmd) < 1)
    error("invalid `url' argument");
    if(length(scmd) > 1)
    warning("only first element of `url' argument used");
    url = CHAR(STRING_ELT(scmd, 0));
    sfile = CAR(args); args = CDR(args);
    if(!isString(sfile) || length(sfile) < 1)
    error("invalid `destfile' argument");
    if(length(sfile) > 1)
    warning("only first element of `destfile' argument used");
    file = CHAR(STRING_ELT(sfile, 0));
    IDquiet = quiet = asLogical(CAR(args)); args = CDR(args);
    if(quiet == NA_LOGICAL)
    error("invalid `quiet' argument");
    smode =  CAR(args); args = CDR(args);
    if(!isString(smode) || length(smode) != 1)
    error("invalid `mode' argument");
    mode = CHAR(STRING_ELT(smode, 0));
    cacheOK = asLogical(CAR(args));
    if(cacheOK == NA_LOGICAL)
    error("invalid `cacheOK' argument");

    if(strncmp(url, "file://", 7) == 0) {
    FILE *in, *out;
    static char buf[CPBUFSIZE];
    size_t n;

    /* Use binary transfers */
    in = R_fopen(R_ExpandFileName(url+7), (mode[2] == 'b') ? "rb" : "r");
    if(!in) error("cannot open URL `%s'", url);
    out = R_fopen(R_ExpandFileName(file), mode);
    if(!out) error("cannot open destfile `%s'", file);
    while((n = fread(buf, 1, CPBUFSIZE, in)) > 0)
        fwrite(buf, 1, n, out);
    fclose(out); fclose(in);

#ifdef HAVE_INTERNET
    } else if (strncmp(url, "http://", 7) == 0) {

    FILE *out;
    void *ctxt;
    int len, total, guess, nnew, nbytes = 0;
    char buf[IBUFSIZE];
#ifndef Win32
    int ndots = 0;
#endif

    out = R_fopen(R_ExpandFileName(file), mode);
    if(!out) error("cannot open destfile `%s'", file);

    R_Busy(1);
    if(!quiet) REprintf("trying URL `%s'\n", url);
#ifdef Win32
    R_FlushConsole();
#endif
    ctxt = in_R_HTTPOpen(url, cacheOK);
    if(ctxt == NULL) status = 1;
    else {
        if(!quiet) REprintf("opened URL\n", url);
        guess = total = ((inetconn *)ctxt)->length;
        if (guess <= 0) guess = 100 * 1024;
#ifdef Win32
        R_FlushConsole();
        wprog = newwindow("Download progress", rect(0, 0, 540, 100),
                  Titlebar | Centered);
        setbackground(wprog, dialog_bg());
        strcpy(buf, "URL: ");
        if(strlen(url) > 60) {
        strcat(buf, "... ");
        strcat(buf, url + (strlen(url) - 60));
        } else strcat(buf, url);
        l_url = newlabel(buf, rect(10, 15, 520, 25), AlignCenter);
        pb = newprogressbar(rect(20, 50, 500, 20), 0, guess, 1024, 1);
        show(wprog);
#endif
        while ((len = in_R_HTTPRead(ctxt, buf, sizeof(buf))) > 0) {
        fwrite(buf, 1, len, out);
        nbytes += len;
        nnew = nbytes/1024;
#ifdef Win32
        if(nbytes > guess) {
            guess *= 2;
            setprogressbarrange(pb, 0, guess);
        }
        setprogressbar(pb, nbytes);
#else
        if(!quiet) putdots(&ndots, nnew);
#endif
        }
        in_R_HTTPClose(ctxt);
        fclose(out);
        if(!quiet) {
#ifndef Win32
        REprintf("\n");
#endif
        if(nbytes > 10240)
            REprintf("downloaded %dKb\n\n", nbytes/1024, url);
        else
            REprintf("downloaded %d bytes\n\n", nbytes, url);
        }
#ifdef Win32
        R_FlushConsole();
        hide(wprog);
        del(l_url);
        del(pb);
        del(wprog);
#endif
        if (total > 0 && total != nbytes)
        warning("downloaded length %d != reported length %d",
            nbytes, total);
    }
    R_Busy(0);
    if (status == 1) error("cannot open URL `%s'", url);

    } else if (strncmp(url, "ftp://", 6) == 0) {

    FILE *out;
    void *ctxt;
    int len, total, guess, nnew, nbytes = 0;
    char buf[IBUFSIZE];
#ifndef Win32
    int ndots = 0;
#endif

    out = R_fopen(R_ExpandFileName(file), mode);
    if(!out) error("cannot open destfile `%s'", file);

    R_Busy(1);
    if(!quiet) REprintf("trying URL `%s'\n", url);
#ifdef Win32
    R_FlushConsole();
#endif
    ctxt = in_R_FTPOpen(url);
    if(ctxt == NULL) status = 1;
    else {
        if(!quiet) REprintf("opened URL\n", url);
        guess = total = ((inetconn *)ctxt)->length;
        if (guess <= 0) guess = 100 * 1024;
#ifdef Win32
        R_FlushConsole();
        wprog = newwindow("Download progress", rect(0, 0, 540, 100),
                  Titlebar | Centered);
        setbackground(wprog, LightGrey);
        strcpy(buf, "URL: ");
        if(strlen(url) > 60) {
        strcat(buf, "... ");
        strcat(buf, url + (strlen(url) - 60));
        } else strcat(buf, url);
        l_url = newlabel(buf, rect(10, 15, 520, 25), AlignCenter);
        pb = newprogressbar(rect(20, 50, 500, 20), 0, guess, 1024, 1);
        show(wprog);
#endif
        while ((len = in_R_FTPRead(ctxt, buf, sizeof(buf))) > 0) {
        fwrite(buf, 1, len, out);
        nbytes += len;
        nnew = nbytes/1024;
#ifdef Win32
        if(nbytes > guess) {
            guess *= 2;
            setprogressbarrange(pb, 0, guess);
        }
        setprogressbar(pb, nbytes);
#else
        if(!quiet) putdots(&ndots, nnew);
#endif
        }
        in_R_FTPClose(ctxt);
        fclose(out);
        if(!quiet) {
#ifndef Win32
        REprintf("\n");
#endif
        if(nbytes > 10240)
            REprintf("downloaded %dKb\n\n", nbytes/1024, url);
        else
            REprintf("downloaded %d bytes\n\n", nbytes, url);
        }
#ifdef Win32
        R_FlushConsole();
        hide(wprog);
        del(l_url);
        del(pb);
        del(wprog);
#endif
        if (total > 0 && total != nbytes)
        warning("downloaded length %d != reported length %d",
            nbytes, total);
    }
    R_Busy(0);
    if (status == 1) error("cannot open URL `%s'", url);
#endif

    } else
    error("unsupported URL scheme");

    PROTECT(ans = allocVector(INTSXP, 1));
    INTEGER(ans)[0] = status;
    UNPROTECT(1);
    return ans;
}


#if defined(SUPPORT_LIBXML) && !defined(USE_WININET)

void *in_R_HTTPOpen(const char *url, int cacheOK)
{
    inetconn *con;
    void *ctxt;
    int timeout = asInteger(GetOption(install("timeout"), R_NilValue));
    int len = -1;
    char *type = NULL;

    if(timeout == NA_INTEGER || timeout <= 0) timeout = 60;

    RxmlNanoHTTPTimeout(timeout);
    ctxt = RxmlNanoHTTPOpen(url, NULL, cacheOK);
    if(ctxt != NULL) {
    int rc = RxmlNanoHTTPReturnCode(ctxt);
    if(rc != 200) {
        RxmlNanoHTTPClose(ctxt);
        warning("cannot open: HTTP status was `%d %s'", rc,
          RxmlNanoHTTPStatusMsg(ctxt));
        return NULL;
    } else {
        type = RxmlNanoHTTPContentType(ctxt);
        len = RxmlNanoHTTPContentLength(ctxt);
        if(!IDquiet){
        REprintf("Content type `%s'", type ? type : "unknown");
        if(len >= 0) REprintf(" length %d bytes\n", len);
        else REprintf(" length unknown\n", len);
#ifdef Win32
        R_FlushConsole();
#endif
        }
    }
    } else return NULL;
    con = (inetconn *) malloc(sizeof(inetconn));
    if(con) {
    con->length = len;
    con->type = type;
    con->ctxt = ctxt;
    }
    return con;
}

static int in_R_HTTPRead(void *ctx, char *dest, int len)
{
    return RxmlNanoHTTPRead(((inetconn *)ctx)->ctxt, dest, len);
}

static void in_R_HTTPClose(void *ctx)
{
    if(ctx) {
    RxmlNanoHTTPClose(((inetconn *)ctx)->ctxt);
    free(ctx);
    }
}

static void *in_R_FTPOpen(const char *url)
{
    inetconn *con;
    void *ctxt;
    int timeout = asInteger(GetOption(install("timeout"), R_NilValue));
    int len = 0;

    if(timeout == NA_INTEGER || timeout <= 0) timeout = 60;
    RxmlNanoFTPTimeout(timeout);
    ctxt = RxmlNanoFTPOpen(url);
    if(!ctxt) return NULL;
    if(!IDquiet) {
    len = RxmlNanoFTPContentLength(ctxt);
    if(len >= 0)
        REprintf("ftp data connection made, file length %d bytes\n", len);
    else
        REprintf("ftp data connection made, file length unknown\n");
#ifdef Win32
    R_FlushConsole();
#endif
    }
    con = (inetconn *) malloc(sizeof(inetconn));
    if(con) {
    con->length = len;
    con->type = NULL;
    con->ctxt = ctxt;
    }
    return con;
}

static int in_R_FTPRead(void *ctx, char *dest, int len)
{
    return RxmlNanoFTPRead(((inetconn *)ctx)->ctxt, dest, len);
}

static void in_R_FTPClose(void *ctx)
{
    if(ctx) {
    RxmlNanoFTPClose(((inetconn *)ctx)->ctxt);
    free(ctx);
    }
}
#endif /* SUPPORT_LIBXML */


#ifdef USE_WININET

#include <windows.h>
#include <wininet.h>
typedef struct wictxt {
    int length;
    char * type;
    HINTERNET hand;
    HINTERNET session;
} wIctxt, *WIctxt;

#ifdef USE_WININET_ASYNC
static int timeout;

static int callback_status;
static LPINTERNET_ASYNC_RESULT callback_res;

static void CALLBACK
InternetCallback(HINTERNET hInternet, DWORD context, DWORD Status,
         LPVOID lpvStatusInformation,
         DWORD dwStatusInformationLength)
{
    callback_status = Status;
    /* printf("callback with context %ld, code %ld\n", context, Status); */
    if(Status == INTERNET_STATUS_REQUEST_COMPLETE) {
    callback_res = (LPINTERNET_ASYNC_RESULT) lpvStatusInformation;
    }
}
#endif /* USE_WININET_ASYNC */

static void *in_R_HTTPOpen(const char *url, const int cacheOK)
{
    WIctxt  wictxt;
    DWORD status, d1 = 4, d2 = 0, d3 = 100;
    char buf[101], *p;

/*  BOOL res = InternetAttemptConnect(0);

    if (res != ERROR_SUCCESS) {
    warning("no Internet connection available");
    return NULL;
    }*/

    wictxt = (WIctxt) malloc(sizeof(wIctxt));
    wictxt->length = -1;
    wictxt->type = NULL;
    wictxt->hand =
    InternetOpen("R", INTERNET_OPEN_TYPE_PRECONFIG, NULL, NULL,
#ifdef USE_WININET_ASYNC
             INTERNET_FLAG_ASYNC
#else
             0
#endif
                 );
    if(!wictxt->hand) {
    free(wictxt);
    /* error("cannot open Internet connection"); */
    return NULL;
    }

#ifdef USE_WININET_ASYNC
    timeout = asInteger(GetOption(install("timeout"), R_NilValue));
    if(timeout == NA_INTEGER || timeout <= 0) timeout = 60;
    InternetSetStatusCallback(wictxt->hand,
                  (INTERNET_STATUS_CALLBACK) InternetCallback);
/*    if(!IDquiet) {
    REprintf("using Asynchronous WinInet calls, timeout %d secs\n",
        timeout);
    R_FlushConsole();
    }*/

    callback_status = 0;
    InternetOpenUrl(wictxt->hand, url,
            NULL, 0,
        INTERNET_FLAG_KEEP_CONNECTION | INTERNET_FLAG_NO_CACHE_WRITE,
            17);

    {
    DWORD t1 = GetTickCount();
    while(callback_status != INTERNET_STATUS_REQUEST_COMPLETE
          && GetTickCount() < t1 + 1000*timeout) {
        R_ProcessEvents();
        Sleep(100);
    }
    if(callback_status != INTERNET_STATUS_REQUEST_COMPLETE) {
        InternetCloseHandle(wictxt->hand);
        free(wictxt);
        warning("InternetOpenUrl timed out");
        return NULL;
    }
    }

    wictxt->session = (HINTERNET) callback_res->dwResult;
#else
/*    if(!IDquiet) {
    REprintf("using Synchronous WinInet calls\n");
    R_FlushConsole();
    } */
    wictxt->session = InternetOpenUrl(wictxt->hand, url,
                      NULL, 0,
        INTERNET_FLAG_KEEP_CONNECTION | INTERNET_FLAG_NO_CACHE_WRITE,
                      0);
#endif /* USE_WININET_ASYNC */
    if(!wictxt->session) {
    DWORD err1 = GetLastError(), err2, blen = 101;
    InternetCloseHandle(wictxt->hand);
    free(wictxt);
    if (err1 == ERROR_INTERNET_EXTENDED_ERROR) {
        InternetGetLastResponseInfo(&err2, buf, &blen);
        /* some of these messages end in \r\n */
        while(1) {
        p = buf + strlen(buf) - 1;
        if(*p == '\n' || *p == '\r') *p = '\0'; else break;
        }
        warning("InternetOpenUrl failed: `%s'", buf);
        return NULL;
    } else {
        FormatMessage( 
        FORMAT_MESSAGE_FROM_HMODULE,
        GetModuleHandle("wininet.dll"),
        err1,
        MAKELANGID(LANG_NEUTRAL, SUBLANG_DEFAULT),
        buf, 101, NULL);
        /* some of these messages end in \r\n */
        while(1) {
        p = buf + strlen(buf) - 1;
        if(*p == '\n' || *p == '\r') *p = '\0'; else break;
        }
        warning("InternetOpenUrl failed: `%s'", buf);
        return NULL;
    }
    }

    HttpQueryInfo(wictxt->session,
          HTTP_QUERY_STATUS_CODE | HTTP_QUERY_FLAG_NUMBER,
          &status, &d1, &d2);
    if(status != 200) {
    d2 = 0;
    HttpQueryInfo(wictxt->session,
              HTTP_QUERY_STATUS_TEXT, &buf, &d3, &d2);
    InternetCloseHandle(wictxt->session);
    InternetCloseHandle(wictxt->hand);
    free(wictxt);
    warning("cannot open: HTTP status was `%d %s'", status, buf);
    return NULL;
    }

    HttpQueryInfo(wictxt->session,
          HTTP_QUERY_CONTENT_TYPE, &buf, &d3, &d2);
    d2 = 0;
    HttpQueryInfo(wictxt->session,
          HTTP_QUERY_CONTENT_LENGTH | HTTP_QUERY_FLAG_NUMBER,
          &status, &d1, &d2);
    wictxt->length = status;
    wictxt->type = strdup(buf);
    if(!IDquiet) {
    REprintf("Content type `%s' length %d bytes\n", buf, status);
    R_FlushConsole();
    }

    R_ProcessEvents();
    return (void *)wictxt;
}

static int in_R_HTTPRead(void *ctx, char *dest, int len)
{
    DWORD nread;

    InternetReadFile(((WIctxt)ctx)->session, dest, len, &nread);
#ifdef USE_WININET_ASYNC
    {
    DWORD t1 = GetTickCount();
    while(callback_status != INTERNET_STATUS_REQUEST_COMPLETE
          && GetTickCount() < t1 + 1000*timeout) {
        R_ProcessEvents();
        Sleep(100);
    }
    if(callback_status != INTERNET_STATUS_REQUEST_COMPLETE) {
        warning("Internet read timed out");
        nread = 0;
    }
    }
#endif
    R_ProcessEvents();
    return (int) nread;
}


static void in_R_HTTPClose(void *ctx)
{
    InternetCloseHandle(((WIctxt)ctx)->session);
    InternetCloseHandle(((WIctxt)ctx)->hand);
    if(((WIctxt)ctx)->type) free(((WIctxt)ctx)->type);
    free(ctx);
}

static void *in_R_FTPOpen(const char *url)
{
    WIctxt  wictxt;

    wictxt = (WIctxt) malloc(sizeof(wIctxt));
    wictxt->length = -1;
    wictxt->type = NULL;

    wictxt->hand =
    InternetOpen("R", INTERNET_OPEN_TYPE_PRECONFIG, NULL, NULL,
#ifdef USE_WININET_ASYNC
             INTERNET_FLAG_ASYNC
#else
             0
#endif
                 );
    if(!wictxt->hand) {
    free(wictxt);
    return NULL;
    }

#ifdef USE_WININET_ASYNC
    timeout = asInteger(GetOption(install("timeout"), R_NilValue));
    if(timeout == NA_INTEGER || timeout <= 0) timeout = 60;
    InternetSetStatusCallback(wictxt->hand,
                  (INTERNET_STATUS_CALLBACK) InternetCallback);
    if(!IDquiet) {
    REprintf("using Asynchronous WinInet calls, timeout %d secs\n",
        timeout);
    R_FlushConsole();
    }

    callback_status = 0;
    InternetOpenUrl(wictxt->hand, url,
            NULL, 0,
        INTERNET_FLAG_KEEP_CONNECTION | INTERNET_FLAG_NO_CACHE_WRITE,
            17);
    {
    DWORD t1 = GetTickCount();
    while(callback_status != INTERNET_STATUS_REQUEST_COMPLETE
          && GetTickCount() < t1 + 1000*timeout) {
        R_ProcessEvents();
        Sleep(100);
    }
    if(callback_status != INTERNET_STATUS_REQUEST_COMPLETE) {
        InternetCloseHandle(wictxt->hand);
        free(wictxt);
        warning("InternetOpenUrl timed out");
        return NULL;
    }
    }

    wictxt->session = (HINTERNET) callback_res->dwResult;
#else
    if(!IDquiet) {
    REprintf("using Synchronous WinInet calls\n");
    R_FlushConsole();
    }
    wictxt->session = InternetOpenUrl(wictxt->hand, url,
                      NULL, 0,
        INTERNET_FLAG_KEEP_CONNECTION | INTERNET_FLAG_NO_CACHE_WRITE,
                      0);
    if(!wictxt->session) {
    char buf[256];
    DWORD err1 = GetLastError(), err2, blen = 256;
    InternetCloseHandle(wictxt->hand);
    free(wictxt);
    if (err1 == ERROR_INTERNET_EXTENDED_ERROR) {
        InternetGetLastResponseInfo(&err2, buf, &blen);
        warning("InternetOpenUrl failed: `%s'", buf);
        return NULL;
    } else {
        FormatMessage( 
        FORMAT_MESSAGE_FROM_HMODULE,
        GetModuleHandle("wininet.dll"),
        err1,
        MAKELANGID(LANG_NEUTRAL, SUBLANG_DEFAULT),
        buf, 101, NULL);
        warning("InternetOpenUrl failed: `%s'", buf);
        return NULL;
    }
    }
#endif /* USE_WININET_ASYNC */
    R_ProcessEvents();
    return (void *)wictxt;
}

static int in_R_FTPRead(void *ctx, char *dest, int len)
{
    return R_HTTPRead(ctx, dest, len);
}

static void in_R_FTPClose(void *ctx)
{
    R_HTTPClose(ctx);
}
#endif

#ifndef HAVE_INTERNET
static void *in_R_HTTPOpen(const char *url, const int cacheOK)
{
    return NULL;
}

static int in_R_HTTPRead(void *ctx, char *dest, int len)
{
    return -1;
}

static void in_R_HTTPClose(void *ctx)
{
}

static void *in_R_FTPOpen(const char *url)
{
    return NULL;
}

static int in_R_FTPRead(void *ctx, char *dest, int len)
{
    return -1;
}

static void in_R_FTPClose(void *ctx)
{
}
#endif


#define MBUFSIZE 8192
void RxmlMessage(int level, const char *format, ...)
{
    int clevel;
    char buf[MBUFSIZE], *p;
    va_list(ap);

    clevel = asInteger(GetOption(install("internet.info"), R_NilValue));
    if(clevel == NA_INTEGER) clevel = 2;
    
    if(level < clevel) return;

    va_start(ap, format);
    vsnprintf(buf, MBUFSIZE, format, ap);
    buf[MBUFSIZE-1] = '\0';
    va_end(ap);
    p = buf + strlen(buf) - 1;
    if(strlen(buf) > 0 && *p == '\n') *p = '\0';
    warning(buf);
}

#include "sock.h"

#ifdef USE_WININET
void R_init_internet2(DllInfo *info)
#else
void R_init_internet(DllInfo *info)
#endif
{
    R_InternetRoutines *tmp;
    tmp = (R_InternetRoutines*) malloc(sizeof(R_InternetRoutines));
    if(!tmp) {
    error("Cannot allocate memory for InternetRoutines structure");
    return;
    }

    tmp->download = in_do_download;
    tmp->newurl =  in_R_newurl;
    tmp->newsock = in_R_newsock;

    tmp->HTTPOpen = in_R_HTTPOpen;
    tmp->HTTPRead = in_R_HTTPRead;
    tmp->HTTPClose = in_R_HTTPClose;

    tmp->FTPOpen = in_R_FTPOpen;
    tmp->FTPRead = in_R_FTPRead;
    tmp->FTPClose = in_R_FTPClose;

    tmp->sockopen = in_Rsockopen;
    tmp->socklisten = in_Rsocklisten;
    tmp->sockconnect = in_Rsockconnect;
    tmp->sockclose = in_Rsockclose;
    tmp->sockread = in_Rsockread;
    tmp->sockwrite = in_Rsockwrite;

    tmp->sockselect = in_Rsockselect;
    R_setInternetRoutines(tmp);
}