Ensure runhaskell is rebuild in stage2
[ghc-hetmet.git] / rts / dyn-wrapper.c
1 /* This is the wrapper for dynamically linked executables
2  *
3  * Have mercy with this creature born in cross-platform wasteland.
4  */
5
6 #include <sys/types.h>
7 #include <unistd.h>
8 #include <sys/stat.h>
9 #include <fcntl.h>
10 #include <stdio.h>
11 #include <string.h>
12 #include <stdlib.h>
13 #include <ghcplatform.h>
14 #include <shell-tools.c>
15
16 /* All defining behavior string */
17 char behaviour[]=BEHAVIOUR;
18
19 #define REAL_EXT "_real"
20 #define REAL_EXT_S (sizeof(REAL_EXT)-1)
21
22 void *smalloc(size_t size);
23
24 #if defined(mingw32_HOST_OS)
25 #include <wtypes.h>
26 #include <winbase.h>
27
28 #define ENV_NAME "PATH"
29 #define ENV_SEP ';'
30 #define EXEEXT ".exe"
31
32 #define SET_ENV(n,v) SetEnvironmentVariable(n,v)
33 #define GET_ENV(n) getEnvWrapper(n)
34 #define FREE_GET_ENV(x) free(x)
35
36 #define DIR_SEP '\\'
37
38 char *getEnvWrapper(const char *name) {
39     int len=GetEnvironmentVariableA(name,NULL,0);
40     char *value;
41     if(!len) return NULL;
42
43     value=smalloc(len);
44     GetEnvironmentVariableA(name,value,len);
45     return value;
46 }
47
48 #define CONVERT_PATH(x) replace(x,'/','\\')
49
50
51 #elif defined(linux_HOST_OS)
52 #define ENV_NAME "LD_LIBRARY_PATH"
53 #define ENV_SEP ':'
54
55 #define EXEEXT ""
56 #define SET_ENV(n,v) setenv(n,v,1)
57 #define GET_ENV(n) getenv(n)
58
59 #define FREE_GET_ENV(x)
60 #define CONVERT_PATH(x)
61 #define DIR_SEP '/'
62
63 #elif defined(darwin_HOST_OS)
64 #define ENV_NAME "DYLD_LIBRARY_PATH"
65 #define ENV_SEP ':'
66
67 #define EXEEXT ""
68 #define SET_ENV(n,v) setenv(n,v,1)
69 #define GET_ENV(n) getenv(n)
70 #define FREE_GET_ENV(x)
71
72 #define CONVERT_PATH(x)
73 #define DIR_SEP '/'
74 #else
75 #error no OS interface defined
76 #endif
77
78 #define EXEEXT_S (sizeof(EXEEXT)-1)
79
80 /* Utility functions */
81
82 /* Like strtok_r but omitting the first arg and allowing only one delimiter */
83 char *stringTokenizer (char **this, const char delim)
84 {
85     char *oldthis=*this;
86     char *matched;
87     if(!this || !(*this)) return NULL;
88
89     matched=strchr(*this, delim);
90     if(matched) {
91         *matched=0;
92         *this=matched+1;
93         return oldthis;
94     } else {
95         *this=NULL;
96         return oldthis;
97     }
98 }
99
100 /* Replaces all occourances of character 'from' with 'to' in 'x' */
101 void replace(char *x, char from, char to) {
102     while(*x) {
103         if(*x == from)
104             *x=to;
105         x++;
106     }
107 }
108
109 /* Non-failing malloc -- will die on failure */
110 void *smalloc(size_t size)
111 {
112     void *ret=malloc(size);
113     if(!ret) {
114         fprintf(stderr,"Can not allocate %d bytes",size);
115         perror("");
116         exit(-1);
117     }
118     return ret;
119 }
120
121 /* String Cons (scons) -- basically a linked list */
122 struct scons {
123     char *value;
124     struct scons *next;
125 };
126
127 /* Free up a linked list */
128 void freescons(struct scons *root) {
129     while(root) {
130         struct scons *c=root;
131         root=root->next;
132         free(c->value);
133         free(c);
134     }
135 }
136
137 /* Removes duplicates among the string cons */
138 struct scons *unique(struct scons *in) {
139     struct scons *ret=NULL;
140     struct scons *ci;
141     for(ci=in; ci!=NULL; ci=ci->next) {
142         struct scons *cj;
143         struct scons *nextscons;
144         for(cj = ret; cj != NULL; cj=cj->next) {
145             if(!strcmp(ci->value,cj->value))
146                 break;
147         }
148         if(cj!=NULL) continue;
149
150         nextscons=smalloc(sizeof(struct scons));
151         nextscons->next=ret;
152         nextscons->value=strdup(ci->value);
153         ret=nextscons;
154     }
155     return ret;
156 }
157
158 /* Tries to get a single line from the input stream really _inefficently_ */
159 char *afgets(FILE *input) {
160         int bufsize=0;
161         char *buf=(char *)malloc(bufsize);
162         do {
163             bufsize+=1;
164             buf=realloc(buf,bufsize);
165         } while(fread(buf+bufsize-1,1,1,input)==1 && buf[bufsize-1]!='\n');
166         buf[bufsize-1]=0;
167         return buf;
168 }
169
170 /* Computes the real binaries' name from argv0 */
171 char *real_binary_name(char *argv0) {
172     int arg0len=strlen(argv0);
173     char *alterego;
174
175     alterego=strdup(argv0);
176     if(!strcmp(alterego+arg0len-EXEEXT_S,EXEEXT)) {
177         alterego[arg0len-EXEEXT_S]=0;
178         arg0len-=EXEEXT_S;
179     }
180     alterego=realloc(alterego,arg0len+REAL_EXT_S+EXEEXT_S+1);
181     sprintf(alterego+arg0len,"%s%s",REAL_EXT,EXEEXT);
182     return alterego;
183 }
184
185 /* Gets a field for a GHC package
186  * This method can't deal with multiline fields
187  */
188 #warning FIXME - getGhcPkgField can not deal with multline fields
189
190 char *getGhcPkgField(char *ghcpkg, char *package, char *field) {
191         char *command;
192         char *line;
193         FILE *input;
194         int fieldLn=strlen(field);
195
196         /* Format ghc-pkg command */
197         command=smalloc(strlen(ghcpkg)+strlen(package)+fieldLn+9);
198         sprintf(command,"%s field %s %s",ghcpkg,package,field);
199
200         /* Run */
201         input=popen(command,"r");
202
203         if(!input) {
204             fprintf(stderr,"Failed to invoke %s", command);
205             perror("");
206             free(command);
207             exit(-1);
208         }
209
210         line=afgets(input);
211
212         pclose(input);
213
214         free(command);
215
216         /* Check for validity */
217         if(strncmp(line,field,fieldLn)) {
218             /* Failed */
219             free(line);
220             return NULL;
221         }
222
223         /* Cut off "<field>: " in the output and return */
224         strcpy(line,line+fieldLn+2);
225         return line;
226 }
227
228 /* Prepends a prefix to an environment variable. 
229    If it is set already, it puts a separator in between */
230
231 void prependenv(char *name, char *prefix, char sep)
232 {
233     char *orig=GET_ENV(name);
234     if(orig) {
235         char *new;
236         int prefixlength=strlen(prefix);
237
238         new=(char *)smalloc(strlen(orig)+prefixlength+2);
239
240         strcpy(new,prefix);
241         new[prefixlength]=sep;
242         strcpy(new+prefixlength+1,orig);
243
244         SET_ENV(name,new);
245         free(new);
246     } else {
247         SET_ENV(name,prefix);
248     }
249     FREE_GET_ENV(orig);
250 }
251
252 /* This function probes the library-dirs of all package dependencies,
253    removes duplicates and adds it to the environment ENV_NAME */
254 void withghcpkg(char *ghcpkg, char *packages)
255 {
256     struct scons *rootlist=NULL;
257     struct scons *uniqueRootlist=NULL;
258     struct scons *c;
259
260     /* Save pointers for strtok */
261     char *packageParse;
262     char *libParse;
263
264     char *curpack;
265
266     while(curpack=stringTokenizer(&packages,';')) {
267 #warning We should query for a dynamic-library field not library-dirs.
268         char *line=getGhcPkgField(ghcpkg, curpack,"library-dirs");
269         char *line_p=line;  /* need to retain original line for freeing */
270         char *curlib;
271
272         if(!line) {
273             fprintf(stderr,"Can not query ghc-pkg for fields of packages %s",curpack);
274             perror("");
275             exit(-1);
276         }
277
278         while(curlib=stringTokenizer(&line_p,' ')) {
279             c=smalloc(sizeof(struct scons));
280             c->next=rootlist;
281             c->value=strdup(curlib);
282             rootlist=c;
283         }
284         free(line);
285     }
286     uniqueRootlist=unique(rootlist);
287     for(c = uniqueRootlist; c != NULL; c=c->next) {
288         CONVERT_PATH(c->value);
289         prependenv(ENV_NAME,c->value,ENV_SEP);
290     }
291     freescons(rootlist);
292     freescons(uniqueRootlist);
293 }
294
295 void add_to(char **base, int *base_size, char **target, const char *src, int src_size) {
296     if((*target)-(*base)+src_size > *base_size) {
297         *base=realloc(*base,*base_size+src_size);
298         *base_size=*base_size+src_size;
299     }
300     memcpy(*target,src,src_size);
301     *target=*target+src_size;
302 }
303
304 /* Scans str and constructs */
305 char *expandFlexiblePath(char *str)
306 {
307     int buffersize=strlen(str)+1;
308     char *base=smalloc(buffersize);
309     char *current=base;
310
311     while(*str && *str!=';') {
312         if(*str=='$' && *(str+1)=='{') {
313             char *start;
314             char *envcont;
315             str+=2;
316             start=str;
317
318             while(*str && *str != '}') {
319                 str++;
320             }
321
322             if(!str) {
323                 fprintf(stderr,"End of string while scanning environment variable. Wrapper broken\n");
324                 exit(-1);
325             }
326             *str='\0';
327             str++;
328             envcont=GET_ENV(start);
329             if(!envcont) {
330                 fprintf(stderr,"Referenced environment variable %s not set.",start);
331                 exit(-1);
332             }
333
334             add_to(&base,&buffersize,&current,envcont,strlen(envcont));
335             FREE_GET_ENV(envcont);
336         } else {
337             add_to(&base,&buffersize,&current,str,1);
338             str++;
339         }
340     }
341     return base;
342 }
343
344 char *getBasename(const char *path) {
345     int i;
346     char *ret;
347     for(i=strlen(path); i>=0; i--) {
348         if(path[i]==DIR_SEP) break;
349     }
350     ret=smalloc(i+1);
351     strncpy(ret,path,i);
352 }
353
354 char *agetcwd() {
355     char *cwd;
356     int size=100;
357     cwd=malloc(size);
358     while(!getcwd(cwd,size)) {
359         size+=100;
360         cwd=realloc(cwd,size);
361     }
362     return cwd;
363 }
364
365 int main(int argc, char **argv) {
366     char *alterego;
367     int arg0len=strlen(argv[0]);
368     switch(behaviour[0]) {
369     case 'H': /* hard paths */
370         replace(behaviour+1,';',ENV_SEP);
371         CONVERT_PATH(behaviour+1);
372         prependenv(ENV_NAME,behaviour+1,ENV_SEP);
373         break;
374     case 'F':
375         { /* flexible paths based on ghc-pkg in $GHC_PKG */
376             char *expanded;
377             char *arg0base=getBasename(argv[0]);
378             char *ghc_pkg=behaviour+1;
379             char *packages;
380             char *oldwd=agetcwd();
381
382             packages=strchr(behaviour+1,';');
383             *packages=0;
384             packages++;
385             expanded=expandFlexiblePath(ghc_pkg);
386
387 #warning Will this also change drive on windows? WINDOWS IS SO BROKEN.
388             chdir(arg0base);
389
390             withghcpkg(expanded,packages);
391             chdir(oldwd);
392             free(oldwd);
393             free(expanded);
394         }
395         break;
396     default:
397         printf("unset wrapper called\n");
398         exit(-1);
399     }
400     alterego=real_binary_name(argv[0]);
401     return run(argv[0],alterego,argc,argv);
402 }