cb921e507d0fdba4452c4f780a8114858c1384b2
[perl.git] / do / caller
1 int
2 do_caller(arg,maxarg,gimme,arglast)
3 ARG *arg;
4 int maxarg;
5 int gimme;
6 int *arglast;
7 {
8     STR **st = stack->ary_array;
9     register int sp = arglast[0];
10     register CSV *csv = curcsv;
11     STR *TARG;
12     int count = 0;
13
14     if (!csv)
15         fatal("There is no caller");
16     if (maxarg)
17         count = (int) str_gnum(st[sp+1]);
18     for (;;) {
19         if (!csv)
20             return sp;
21         if (DBsub && csv->oldcsv && csv->oldcsv->sub == stab_sub(DBsub))
22             count++;
23         if (!count--)
24             break;
25         csv = csv->oldcsv;
26     }
27     if (gimme != G_ARRAY) {
28         STR *TARG = ARGTARG;
29         str_set(TARG,csv->oldcmd->c_stash->tbl_name);
30         STABSET(TARG);
31         st[++sp] = TARG;
32         return sp;
33     }
34
35 #ifndef lint
36     (void)astore(stack,++sp,
37       str_2mortal(str_make(csv->oldcmd->c_stash->tbl_name,0)) );
38     (void)astore(stack,++sp,
39       str_2mortal(str_make(stab_val(csv->oldcmd->c_filestab)->str_ptr,0)) );
40     (void)astore(stack,++sp,
41       str_2mortal(str_nmake((double)csv->oldcmd->c_line)) );
42     if (!maxarg)
43         return sp;
44     TARG = Str_new(49,0);
45     stab_efullname(TARG, csv->stab);
46     (void)astore(stack,++sp, str_2mortal(TARG));
47     (void)astore(stack,++sp,
48       str_2mortal(str_nmake((double)csv->hasargs)) );
49     (void)astore(stack,++sp,
50       str_2mortal(str_nmake((double)csv->wantarray)) );
51     if (csv->hasargs) {
52         ARRAY *ary = csv->argarray;
53
54         if (!dbargs)
55             dbargs = stab_xarray(aadd(stabent("DB'args", TRUE)));
56         if (dbargs->ary_max < ary->ary_fill)
57             astore(dbargs,ary->ary_fill,Nullstr);
58         Copy(ary->ary_array, dbargs->ary_array, ary->ary_fill+1, STR*);
59         dbargs->ary_fill = ary->ary_fill;
60     }
61 #else
62     (void)astore(stack,++sp,
63       str_2mortal(str_make("",0)));
64 #endif
65     return sp;
66 }
67