/
if_perl.xs
1291 lines (1165 loc) · 32.2 KB
/
if_perl.xs
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
830
831
832
833
834
835
836
837
838
839
840
841
842
843
844
845
846
847
848
849
850
851
852
853
854
855
856
857
858
859
860
861
862
863
864
865
866
867
868
869
870
871
872
873
874
875
876
877
878
879
880
881
882
883
884
885
886
887
888
889
890
891
892
893
894
895
896
897
898
899
900
901
902
903
904
905
906
907
908
909
910
911
912
913
914
915
916
917
918
919
920
921
922
923
924
925
926
927
928
929
930
931
932
933
934
935
936
937
938
939
940
941
942
943
944
945
946
947
948
949
950
951
952
953
954
955
956
957
958
959
960
961
962
963
964
965
966
967
968
969
970
971
972
973
974
975
976
977
978
979
980
981
982
983
984
985
986
987
988
989
990
991
992
993
994
995
996
997
998
999
1000
/* vi:set ts=8 sts=4 sw=4:
*
* VIM - Vi IMproved by Bram Moolenaar
*
* Do ":help uganda" in Vim to read copying and usage conditions.
* Do ":help credits" in Vim to see a list of people who contributed.
*/
/*
* if_perl.xs: Main code for Perl interface support.
* Mostly written by Sven Verdoolaege.
*/
#define _memory_h /* avoid memset redeclaration */
#define IN_PERL_FILE /* don't include if_perl.pro from proto.h */
#include "vim.h"
/*
* Work around clashes between Perl and Vim namespace. proto.h doesn't
* include if_perl.pro and perlsfio.pro when IN_PERL_FILE is defined, because
* we need the CV typedef. proto.h can't be moved to after including
* if_perl.h, because we get all sorts of name clashes then.
*/
#ifndef PROTO
#ifndef __MINGW32__
# include "proto/if_perl.pro"
# include "proto/if_perlsfio.pro"
#endif
#endif
/* Perl compatibility stuff. This should ensure compatibility with older
* versions of Perl.
*/
#ifndef PERL_VERSION
# include <patchlevel.h>
# define PERL_REVISION 5
# define PERL_VERSION PATCHLEVEL
# define PERL_SUBVERSION SUBVERSION
#endif
/*
* Quoting Jan Dubois of Active State:
* ActivePerl build 822 still identifies itself as 5.8.8 but already
* contains many of the changes from the upcoming Perl 5.8.9 release.
*
* The changes include addition of two symbols (Perl_sv_2iv_flags,
* Perl_newXS_flags) not present in earlier releases.
*
* Jan Dubois suggested the following guarding scheme.
*
* Active State defined ACTIVEPERL_VERSION as a string in versions before
* 5.8.8; and so the comparison to 822 below needs to be guarded.
*/
#if (PERL_REVISION == 5) && (PERL_VERSION == 8) && (PERL_SUBVERSION >= 8)
# if (ACTIVEPERL_VERSION >= 822) || (PERL_SUBVERSION >= 9)
# define PERL589_OR_LATER
# endif
#endif
#if (PERL_REVISION == 5) && (PERL_VERSION >= 9)
# define PERL589_OR_LATER
#endif
#ifndef pTHX
# define pTHX void
# define pTHX_
#endif
#ifndef EXTERN_C
# define EXTERN_C
#endif
/* Compatibility hacks over */
static PerlInterpreter *perl_interp = NULL;
static void xs_init __ARGS((pTHX));
static void VIM_init __ARGS((void));
EXTERN_C void boot_DynaLoader __ARGS((pTHX_ CV*));
/*
* For dynamic linked perl. (Windows)
*/
#if defined(DYNAMIC_PERL) || defined(PROTO)
/*
* Wrapper defines
*/
# define perl_alloc dll_perl_alloc
# define perl_construct dll_perl_construct
# define perl_parse dll_perl_parse
# define perl_run dll_perl_run
# define perl_destruct dll_perl_destruct
# define perl_free dll_perl_free
# define Perl_get_context dll_Perl_get_context
# define Perl_croak dll_Perl_croak
# ifndef PROTO
# define Perl_croak_nocontext dll_Perl_croak_nocontext
# define Perl_call_argv dll_Perl_call_argv
# define Perl_call_pv dll_Perl_call_pv
# define Perl_eval_sv dll_Perl_eval_sv
# define Perl_get_sv dll_Perl_get_sv
# define Perl_eval_pv dll_Perl_eval_pv
# define Perl_call_method dll_Perl_call_method
# endif
# define Perl_dowantarray dll_Perl_dowantarray
# define Perl_free_tmps dll_Perl_free_tmps
# define Perl_gv_stashpv dll_Perl_gv_stashpv
# define Perl_markstack_grow dll_Perl_markstack_grow
# define Perl_mg_find dll_Perl_mg_find
# define Perl_newXS dll_Perl_newXS
# define Perl_newSV dll_Perl_newSV
# define Perl_newSViv dll_Perl_newSViv
# define Perl_newSVpv dll_Perl_newSVpv
# define Perl_pop_scope dll_Perl_pop_scope
# define Perl_push_scope dll_Perl_push_scope
# define Perl_save_int dll_Perl_save_int
# define Perl_stack_grow dll_Perl_stack_grow
# define Perl_set_context dll_Perl_set_context
# define Perl_sv_2bool dll_Perl_sv_2bool
# define Perl_sv_2iv dll_Perl_sv_2iv
# define Perl_sv_2mortal dll_Perl_sv_2mortal
# if (PERL_REVISION == 5) && (PERL_VERSION >= 8)
# define Perl_sv_2pv_flags dll_Perl_sv_2pv_flags
# define Perl_sv_2pv_nolen dll_Perl_sv_2pv_nolen
# else
# define Perl_sv_2pv dll_Perl_sv_2pv
# endif
# define Perl_sv_bless dll_Perl_sv_bless
# if (PERL_REVISION == 5) && (PERL_VERSION >= 8)
# define Perl_sv_catpvn_flags dll_Perl_sv_catpvn_flags
# else
# define Perl_sv_catpvn dll_Perl_sv_catpvn
# endif
#ifdef PERL589_OR_LATER
# define Perl_sv_2iv_flags dll_Perl_sv_2iv_flags
# define Perl_newXS_flags dll_Perl_newXS_flags
#endif
# define Perl_sv_free dll_Perl_sv_free
# if (PERL_REVISION == 5) && (PERL_VERSION >= 10)
# define Perl_sv_free2 dll_Perl_sv_free2
# endif
# define Perl_sv_isa dll_Perl_sv_isa
# define Perl_sv_magic dll_Perl_sv_magic
# define Perl_sv_setiv dll_Perl_sv_setiv
# define Perl_sv_setpv dll_Perl_sv_setpv
# define Perl_sv_setpvn dll_Perl_sv_setpvn
# if (PERL_REVISION == 5) && (PERL_VERSION >= 8)
# define Perl_sv_setsv_flags dll_Perl_sv_setsv_flags
# else
# define Perl_sv_setsv dll_Perl_sv_setsv
# endif
# define Perl_sv_upgrade dll_Perl_sv_upgrade
# define Perl_Tstack_sp_ptr dll_Perl_Tstack_sp_ptr
# define Perl_Top_ptr dll_Perl_Top_ptr
# define Perl_Tstack_base_ptr dll_Perl_Tstack_base_ptr
# define Perl_Tstack_max_ptr dll_Perl_Tstack_max_ptr
# define Perl_Ttmps_ix_ptr dll_Perl_Ttmps_ix_ptr
# define Perl_Ttmps_floor_ptr dll_Perl_Ttmps_floor_ptr
# define Perl_Tmarkstack_ptr_ptr dll_Perl_Tmarkstack_ptr_ptr
# define Perl_Tmarkstack_max_ptr dll_Perl_Tmarkstack_max_ptr
# define Perl_TSv_ptr dll_Perl_TSv_ptr
# define Perl_TXpv_ptr dll_Perl_TXpv_ptr
# define Perl_Tna_ptr dll_Perl_Tna_ptr
# define Perl_Idefgv_ptr dll_Perl_Idefgv_ptr
# define Perl_Ierrgv_ptr dll_Perl_Ierrgv_ptr
# define Perl_Isv_yes_ptr dll_Perl_Isv_yes_ptr
# define boot_DynaLoader dll_boot_DynaLoader
# define Perl_sys_init dll_Perl_sys_init
# define Perl_sys_term dll_Perl_sys_term
# define Perl_ISv_ptr dll_Perl_ISv_ptr
# define Perl_Istack_max_ptr dll_Perl_Istack_max_ptr
# define Perl_Istack_base_ptr dll_Perl_Istack_base_ptr
# define Perl_Itmps_ix_ptr dll_Perl_Itmps_ix_ptr
# define Perl_Itmps_floor_ptr dll_Perl_Itmps_floor_ptr
# define Perl_IXpv_ptr dll_Perl_IXpv_ptr
# define Perl_Ina_ptr dll_Perl_Ina_ptr
# define Perl_Imarkstack_ptr_ptr dll_Perl_Imarkstack_ptr_ptr
# define Perl_Imarkstack_max_ptr dll_Perl_Imarkstack_max_ptr
# define Perl_Istack_sp_ptr dll_Perl_Istack_sp_ptr
# define Perl_Iop_ptr dll_Perl_Iop_ptr
# define Perl_call_list dll_Perl_call_list
# define Perl_Iscopestack_ix_ptr dll_Perl_Iscopestack_ix_ptr
# define Perl_Iunitcheckav_ptr dll_Perl_Iunitcheckav_ptr
#ifndef DYNAMIC_PERL /* just generating prototypes */
typedef int HANDLE;
typedef int XSINIT_t;
typedef int XSUBADDR_t;
#endif
/*
* Declare HANDLE for perl.dll and function pointers.
*/
static HANDLE hPerlLib = NULL;
static PerlInterpreter* (*perl_alloc)();
static void (*perl_construct)(PerlInterpreter*);
static void (*perl_destruct)(PerlInterpreter*);
static void (*perl_free)(PerlInterpreter*);
static int (*perl_run)(PerlInterpreter*);
static int (*perl_parse)(PerlInterpreter*, XSINIT_t, int, char**, char**);
static void* (*Perl_get_context)(void);
static void (*Perl_croak)(pTHX_ const char*, ...);
static void (*Perl_croak_nocontext)(const char*, ...);
static I32 (*Perl_dowantarray)(pTHX);
static void (*Perl_free_tmps)(pTHX);
static HV* (*Perl_gv_stashpv)(pTHX_ const char*, I32);
static void (*Perl_markstack_grow)(pTHX);
static MAGIC* (*Perl_mg_find)(pTHX_ SV*, int);
static CV* (*Perl_newXS)(pTHX_ char*, XSUBADDR_t, char*);
static SV* (*Perl_newSV)(pTHX_ STRLEN);
static SV* (*Perl_newSViv)(pTHX_ IV);
static SV* (*Perl_newSVpv)(pTHX_ const char*, STRLEN);
static I32 (*Perl_call_argv)(pTHX_ const char*, I32, char**);
static I32 (*Perl_call_pv)(pTHX_ const char*, I32);
static I32 (*Perl_eval_sv)(pTHX_ SV*, I32);
static SV* (*Perl_get_sv)(pTHX_ const char*, I32);
static SV* (*Perl_eval_pv)(pTHX_ const char*, I32);
static SV* (*Perl_call_method)(pTHX_ const char*, I32);
static void (*Perl_pop_scope)(pTHX);
static void (*Perl_push_scope)(pTHX);
static void (*Perl_save_int)(pTHX_ int*);
static SV** (*Perl_stack_grow)(pTHX_ SV**, SV**p, int);
static SV** (*Perl_set_context)(void*);
static bool (*Perl_sv_2bool)(pTHX_ SV*);
static IV (*Perl_sv_2iv)(pTHX_ SV*);
static SV* (*Perl_sv_2mortal)(pTHX_ SV*);
#if (PERL_REVISION == 5) && (PERL_VERSION >= 8)
static char* (*Perl_sv_2pv_flags)(pTHX_ SV*, STRLEN*, I32);
static char* (*Perl_sv_2pv_nolen)(pTHX_ SV*);
#else
static char* (*Perl_sv_2pv)(pTHX_ SV*, STRLEN*);
#endif
static SV* (*Perl_sv_bless)(pTHX_ SV*, HV*);
#if (PERL_REVISION == 5) && (PERL_VERSION >= 8)
static void (*Perl_sv_catpvn_flags)(pTHX_ SV* , const char*, STRLEN, I32);
#else
static void (*Perl_sv_catpvn)(pTHX_ SV*, const char*, STRLEN);
#endif
#ifdef PERL589_OR_LATER
static IV (*Perl_sv_2iv_flags)(pTHX_ SV* sv, I32 flags);
static CV * (*Perl_newXS_flags)(pTHX_ const char *name, XSUBADDR_t subaddr, const char *const filename, const char *const proto, U32 flags);
#endif
static void (*Perl_sv_free)(pTHX_ SV*);
static int (*Perl_sv_isa)(pTHX_ SV*, const char*);
static void (*Perl_sv_magic)(pTHX_ SV*, SV*, int, const char*, I32);
static void (*Perl_sv_setiv)(pTHX_ SV*, IV);
static void (*Perl_sv_setpv)(pTHX_ SV*, const char*);
static void (*Perl_sv_setpvn)(pTHX_ SV*, const char*, STRLEN);
#if (PERL_REVISION == 5) && (PERL_VERSION >= 8)
static void (*Perl_sv_setsv_flags)(pTHX_ SV*, SV*, I32);
#else
static void (*Perl_sv_setsv)(pTHX_ SV*, SV*);
#endif
static bool (*Perl_sv_upgrade)(pTHX_ SV*, U32);
static SV*** (*Perl_Tstack_sp_ptr)(register PerlInterpreter*);
static OP** (*Perl_Top_ptr)(register PerlInterpreter*);
static SV*** (*Perl_Tstack_base_ptr)(register PerlInterpreter*);
static SV*** (*Perl_Tstack_max_ptr)(register PerlInterpreter*);
static I32* (*Perl_Ttmps_ix_ptr)(register PerlInterpreter*);
static I32* (*Perl_Ttmps_floor_ptr)(register PerlInterpreter*);
static I32** (*Perl_Tmarkstack_ptr_ptr)(register PerlInterpreter*);
static I32** (*Perl_Tmarkstack_max_ptr)(register PerlInterpreter*);
static SV** (*Perl_TSv_ptr)(register PerlInterpreter*);
static XPV** (*Perl_TXpv_ptr)(register PerlInterpreter*);
static STRLEN* (*Perl_Tna_ptr)(register PerlInterpreter*);
static GV** (*Perl_Idefgv_ptr)(register PerlInterpreter*);
static GV** (*Perl_Ierrgv_ptr)(register PerlInterpreter*);
static SV* (*Perl_Isv_yes_ptr)(register PerlInterpreter*);
static void (*boot_DynaLoader)_((pTHX_ CV*));
#if (PERL_REVISION == 5) && (PERL_VERSION >= 10)
static void (*Perl_sv_free2)(pTHX_ SV*);
static void (*Perl_sys_init)(int* argc, char*** argv);
static void (*Perl_sys_term)(void);
static SV** (*Perl_ISv_ptr)(register PerlInterpreter*);
static SV*** (*Perl_Istack_max_ptr)(register PerlInterpreter*);
static SV*** (*Perl_Istack_base_ptr)(register PerlInterpreter*);
static XPV** (*Perl_IXpv_ptr)(register PerlInterpreter*);
static I32* (*Perl_Itmps_ix_ptr)(register PerlInterpreter*);
static I32* (*Perl_Itmps_floor_ptr)(register PerlInterpreter*);
static STRLEN* (*Perl_Ina_ptr)(register PerlInterpreter*);
static I32** (*Perl_Imarkstack_ptr_ptr)(register PerlInterpreter*);
static I32** (*Perl_Imarkstack_max_ptr)(register PerlInterpreter*);
static SV*** (*Perl_Istack_sp_ptr)(register PerlInterpreter*);
static OP** (*Perl_Iop_ptr)(register PerlInterpreter*);
static void (*Perl_call_list)(pTHX_ I32, AV*);
static I32* (*Perl_Iscopestack_ix_ptr)(register PerlInterpreter*);
static AV** (*Perl_Iunitcheckav_ptr)(register PerlInterpreter*);
#endif
/*
* Table of name to function pointer of perl.
*/
#define PERL_PROC FARPROC
static struct {
char* name;
PERL_PROC* ptr;
} perl_funcname_table[] = {
{"perl_alloc", (PERL_PROC*)&perl_alloc},
{"perl_construct", (PERL_PROC*)&perl_construct},
{"perl_destruct", (PERL_PROC*)&perl_destruct},
{"perl_free", (PERL_PROC*)&perl_free},
{"perl_run", (PERL_PROC*)&perl_run},
{"perl_parse", (PERL_PROC*)&perl_parse},
{"Perl_get_context", (PERL_PROC*)&Perl_get_context},
{"Perl_croak", (PERL_PROC*)&Perl_croak},
{"Perl_croak_nocontext", (PERL_PROC*)&Perl_croak_nocontext},
{"Perl_dowantarray", (PERL_PROC*)&Perl_dowantarray},
{"Perl_free_tmps", (PERL_PROC*)&Perl_free_tmps},
{"Perl_gv_stashpv", (PERL_PROC*)&Perl_gv_stashpv},
{"Perl_markstack_grow", (PERL_PROC*)&Perl_markstack_grow},
{"Perl_mg_find", (PERL_PROC*)&Perl_mg_find},
{"Perl_newXS", (PERL_PROC*)&Perl_newXS},
{"Perl_newSV", (PERL_PROC*)&Perl_newSV},
{"Perl_newSViv", (PERL_PROC*)&Perl_newSViv},
{"Perl_newSVpv", (PERL_PROC*)&Perl_newSVpv},
{"Perl_call_argv", (PERL_PROC*)&Perl_call_argv},
{"Perl_call_pv", (PERL_PROC*)&Perl_call_pv},
{"Perl_eval_sv", (PERL_PROC*)&Perl_eval_sv},
{"Perl_get_sv", (PERL_PROC*)&Perl_get_sv},
{"Perl_eval_pv", (PERL_PROC*)&Perl_eval_pv},
{"Perl_call_method", (PERL_PROC*)&Perl_call_method},
{"Perl_pop_scope", (PERL_PROC*)&Perl_pop_scope},
{"Perl_push_scope", (PERL_PROC*)&Perl_push_scope},
{"Perl_save_int", (PERL_PROC*)&Perl_save_int},
{"Perl_stack_grow", (PERL_PROC*)&Perl_stack_grow},
{"Perl_set_context", (PERL_PROC*)&Perl_set_context},
{"Perl_sv_2bool", (PERL_PROC*)&Perl_sv_2bool},
{"Perl_sv_2iv", (PERL_PROC*)&Perl_sv_2iv},
{"Perl_sv_2mortal", (PERL_PROC*)&Perl_sv_2mortal},
#if (PERL_REVISION == 5) && (PERL_VERSION >= 8)
{"Perl_sv_2pv_flags", (PERL_PROC*)&Perl_sv_2pv_flags},
{"Perl_sv_2pv_nolen", (PERL_PROC*)&Perl_sv_2pv_nolen},
#else
{"Perl_sv_2pv", (PERL_PROC*)&Perl_sv_2pv},
#endif
#ifdef PERL589_OR_LATER
{"Perl_sv_2iv_flags", (PERL_PROC*)&Perl_sv_2iv_flags},
{"Perl_newXS_flags", (PERL_PROC*)&Perl_newXS_flags},
#endif
{"Perl_sv_bless", (PERL_PROC*)&Perl_sv_bless},
#if (PERL_REVISION == 5) && (PERL_VERSION >= 8)
{"Perl_sv_catpvn_flags", (PERL_PROC*)&Perl_sv_catpvn_flags},
#else
{"Perl_sv_catpvn", (PERL_PROC*)&Perl_sv_catpvn},
#endif
{"Perl_sv_free", (PERL_PROC*)&Perl_sv_free},
{"Perl_sv_isa", (PERL_PROC*)&Perl_sv_isa},
{"Perl_sv_magic", (PERL_PROC*)&Perl_sv_magic},
{"Perl_sv_setiv", (PERL_PROC*)&Perl_sv_setiv},
{"Perl_sv_setpv", (PERL_PROC*)&Perl_sv_setpv},
{"Perl_sv_setpvn", (PERL_PROC*)&Perl_sv_setpvn},
#if (PERL_REVISION == 5) && (PERL_VERSION >= 8)
{"Perl_sv_setsv_flags", (PERL_PROC*)&Perl_sv_setsv_flags},
#else
{"Perl_sv_setsv", (PERL_PROC*)&Perl_sv_setsv},
#endif
{"Perl_sv_upgrade", (PERL_PROC*)&Perl_sv_upgrade},
#if (PERL_REVISION == 5) && (PERL_VERSION < 10)
{"Perl_Tstack_sp_ptr", (PERL_PROC*)&Perl_Tstack_sp_ptr},
{"Perl_Top_ptr", (PERL_PROC*)&Perl_Top_ptr},
{"Perl_Tstack_base_ptr", (PERL_PROC*)&Perl_Tstack_base_ptr},
{"Perl_Tstack_max_ptr", (PERL_PROC*)&Perl_Tstack_max_ptr},
{"Perl_Ttmps_ix_ptr", (PERL_PROC*)&Perl_Ttmps_ix_ptr},
{"Perl_Ttmps_floor_ptr", (PERL_PROC*)&Perl_Ttmps_floor_ptr},
{"Perl_Tmarkstack_ptr_ptr", (PERL_PROC*)&Perl_Tmarkstack_ptr_ptr},
{"Perl_Tmarkstack_max_ptr", (PERL_PROC*)&Perl_Tmarkstack_max_ptr},
{"Perl_TSv_ptr", (PERL_PROC*)&Perl_TSv_ptr},
{"Perl_TXpv_ptr", (PERL_PROC*)&Perl_TXpv_ptr},
{"Perl_Tna_ptr", (PERL_PROC*)&Perl_Tna_ptr},
#else
{"Perl_sv_free2", (PERL_PROC*)&Perl_sv_free2},
{"Perl_sys_init", (PERL_PROC*)&Perl_sys_init},
{"Perl_sys_term", (PERL_PROC*)&Perl_sys_term},
{"Perl_ISv_ptr", (PERL_PROC*)&Perl_ISv_ptr},
{"Perl_Istack_sp_ptr", (PERL_PROC*)&Perl_Istack_sp_ptr},
{"Perl_Iop_ptr", (PERL_PROC*)&Perl_Iop_ptr},
{"Perl_Istack_base_ptr", (PERL_PROC*)&Perl_Istack_base_ptr},
{"Perl_Istack_max_ptr", (PERL_PROC*)&Perl_Istack_max_ptr},
{"Perl_Itmps_ix_ptr", (PERL_PROC*)&Perl_Itmps_ix_ptr},
{"Perl_Itmps_floor_ptr", (PERL_PROC*)&Perl_Itmps_floor_ptr},
{"Perl_Imarkstack_ptr_ptr", (PERL_PROC*)&Perl_Imarkstack_ptr_ptr},
{"Perl_Imarkstack_max_ptr", (PERL_PROC*)&Perl_Imarkstack_max_ptr},
{"Perl_ISv_ptr", (PERL_PROC*)&Perl_ISv_ptr},
{"Perl_IXpv_ptr", (PERL_PROC*)&Perl_IXpv_ptr},
{"Perl_Ina_ptr", (PERL_PROC*)&Perl_Ina_ptr},
{"Perl_call_list", (PERL_PROC*)&Perl_call_list},
{"Perl_Iscopestack_ix_ptr", (PERL_PROC*)&Perl_Iscopestack_ix_ptr},
{"Perl_Iunitcheckav_ptr", (PERL_PROC*)&Perl_Iunitcheckav_ptr},
#endif
{"Perl_Idefgv_ptr", (PERL_PROC*)&Perl_Idefgv_ptr},
{"Perl_Ierrgv_ptr", (PERL_PROC*)&Perl_Ierrgv_ptr},
{"Perl_Isv_yes_ptr", (PERL_PROC*)&Perl_Isv_yes_ptr},
{"boot_DynaLoader", (PERL_PROC*)&boot_DynaLoader},
{"", NULL},
};
/*
* Make all runtime-links of perl.
*
* 1. Get module handle using LoadLibraryEx.
* 2. Get pointer to perl function by GetProcAddress.
* 3. Repeat 2, until get all functions will be used.
*
* Parameter 'libname' provides name of DLL.
* Return OK or FAIL.
*/
static int
perl_runtime_link_init(char *libname, int verbose)
{
int i;
if (hPerlLib != NULL)
return OK;
if (!(hPerlLib = LoadLibraryEx(libname, NULL, 0)))
{
if (verbose)
EMSG2(_("E370: Could not load library %s"), libname);
return FAIL;
}
for (i = 0; perl_funcname_table[i].ptr; ++i)
{
if (!(*perl_funcname_table[i].ptr = GetProcAddress(hPerlLib,
perl_funcname_table[i].name)))
{
FreeLibrary(hPerlLib);
hPerlLib = NULL;
if (verbose)
EMSG2(_(e_loadfunc), perl_funcname_table[i].name);
return FAIL;
}
}
return OK;
}
/*
* If runtime-link-perl(DLL) was loaded successfully, return TRUE.
* There were no DLL loaded, return FALSE.
*/
int
perl_enabled(verbose)
int verbose;
{
return perl_runtime_link_init(DYNAMIC_PERL_DLL, verbose) == OK;
}
#endif /* DYNAMIC_PERL */
/*
* perl_init(): initialize perl interpreter
* We have to call perl_parse to initialize some structures,
* there's nothing to actually parse.
*/
static void
perl_init()
{
char *bootargs[] = { "VI", NULL };
int argc = 3;
static char *argv[] = { "", "-e", "" };
#if (PERL_REVISION == 5) && (PERL_VERSION >= 10)
Perl_sys_init(&argc, (char***)&argv);
#endif
perl_interp = perl_alloc();
perl_construct(perl_interp);
perl_parse(perl_interp, xs_init, argc, argv, 0);
perl_call_argv("VIM::bootstrap", (long)G_DISCARD, bootargs);
VIM_init();
#ifdef USE_SFIO
sfdisc(PerlIO_stdout(), sfdcnewvim());
sfdisc(PerlIO_stderr(), sfdcnewvim());
sfsetbuf(PerlIO_stdout(), NULL, 0);
sfsetbuf(PerlIO_stderr(), NULL, 0);
#endif
}
/*
* perl_end(): clean up after ourselves
*/
void
perl_end()
{
if (perl_interp)
{
perl_run(perl_interp);
perl_destruct(perl_interp);
perl_free(perl_interp);
perl_interp = NULL;
#if (PERL_REVISION == 5) && (PERL_VERSION >= 10)
Perl_sys_term();
#endif
}
#ifdef DYNAMIC_PERL
if (hPerlLib)
{
FreeLibrary(hPerlLib);
hPerlLib = NULL;
}
#endif
}
/*
* msg_split(): send a message to the message handling routines
* split at '\n' first though.
*/
void
msg_split(s, attr)
char_u *s;
int attr; /* highlighting attributes */
{
char *next;
char *token = (char *)s;
while ((next = strchr(token, '\n')) && !got_int)
{
*next++ = '\0'; /* replace \n with \0 */
msg_attr((char_u *)token, attr);
token = next;
}
if (*token && !got_int)
msg_attr((char_u *)token, attr);
}
#ifndef FEAT_EVAL
/*
* This stub is needed because an "#ifdef FEAT_EVAL" around Eval() doesn't
* work properly.
*/
char_u *
eval_to_string(arg, nextcmd, dolist)
char_u *arg;
char_u **nextcmd;
int dolist;
{
return NULL;
}
#endif
/*
* Create a new reference to an SV pointing to the SCR structure
* The b_perl_private/w_perl_private part of the SCR structure points to the
* SV, so there can only be one such SV for a particular SCR structure. When
* the last reference has gone (DESTROY is called),
* b_perl_private/w_perl_private is reset; When the screen goes away before
* all references are gone, the value of the SV is reset;
* any subsequent use of any of those reference will produce
* a warning. (see typemap)
*/
static SV *
newWINrv(rv, ptr)
SV *rv;
win_T *ptr;
{
sv_upgrade(rv, SVt_RV);
if (ptr->w_perl_private == NULL)
{
ptr->w_perl_private = newSV(0);
sv_setiv(ptr->w_perl_private, (IV)ptr);
}
else
SvREFCNT_inc(ptr->w_perl_private);
SvRV(rv) = ptr->w_perl_private;
SvROK_on(rv);
return sv_bless(rv, gv_stashpv("VIWIN", TRUE));
}
static SV *
newBUFrv(rv, ptr)
SV *rv;
buf_T *ptr;
{
sv_upgrade(rv, SVt_RV);
if (ptr->b_perl_private == NULL)
{
ptr->b_perl_private = newSV(0);
sv_setiv(ptr->b_perl_private, (IV)ptr);
}
else
SvREFCNT_inc(ptr->b_perl_private);
SvRV(rv) = ptr->b_perl_private;
SvROK_on(rv);
return sv_bless(rv, gv_stashpv("VIBUF", TRUE));
}
/*
* perl_win_free
* Remove all refences to the window to be destroyed
*/
void
perl_win_free(wp)
win_T *wp;
{
if (wp->w_perl_private)
sv_setiv((SV *)wp->w_perl_private, 0);
return;
}
void
perl_buf_free(bp)
buf_T *bp;
{
if (bp->b_perl_private)
sv_setiv((SV *)bp->b_perl_private, 0);
return;
}
#ifndef PROTO
# if (PERL_REVISION == 5) && (PERL_VERSION >= 8)
I32 cur_val(pTHX_ IV iv, SV *sv);
# else
I32 cur_val(IV iv, SV *sv);
#endif
/*
* Handler for the magic variables $main::curwin and $main::curbuf.
* The handler is put into the magic vtbl for these variables.
* (This is effectively a C-level equivalent of a tied variable).
* There is no "set" function as the variables are read-only.
*/
# if (PERL_REVISION == 5) && (PERL_VERSION >= 8)
I32 cur_val(pTHX_ IV iv, SV *sv)
# else
I32 cur_val(IV iv, SV *sv)
# endif
{
SV *rv;
if (iv == 0)
rv = newWINrv(newSV(0), curwin);
else
rv = newBUFrv(newSV(0), curbuf);
sv_setsv(sv, rv);
return 0;
}
#endif /* !PROTO */
struct ufuncs cw_funcs = { cur_val, 0, 0 };
struct ufuncs cb_funcs = { cur_val, 0, 1 };
/*
* VIM_init(): Vim-specific initialisation.
* Make the magical main::curwin and main::curbuf variables
*/
static void
VIM_init()
{
static char cw[] = "main::curwin";
static char cb[] = "main::curbuf";
SV *sv;
sv = perl_get_sv(cw, TRUE);
sv_magic(sv, NULL, 'U', (char *)&cw_funcs, sizeof(cw_funcs));
SvREADONLY_on(sv);
sv = perl_get_sv(cb, TRUE);
sv_magic(sv, NULL, 'U', (char *)&cb_funcs, sizeof(cb_funcs));
SvREADONLY_on(sv);
/*
* Setup the Safe compartment.
* It shouldn't be a fatal error if the Safe module is missing.
* XXX: Only shares the 'Msg' routine (which has to be called
* like 'Msg(...)').
*/
(void)perl_eval_pv( "if ( eval( 'require Safe' ) ) { $VIM::safe = Safe->new(); $VIM::safe->share_from( 'VIM', ['Msg'] ); }", G_DISCARD | G_VOID );
}
#ifdef DYNAMIC_PERL
static char *e_noperl = N_("Sorry, this command is disabled: the Perl library could not be loaded.");
#endif
/*
* ":perl"
*/
void
ex_perl(eap)
exarg_T *eap;
{
char *err;
char *script;
STRLEN length;
SV *sv;
SV *safe;
script = (char *)script_get(eap, eap->arg);
if (eap->skip)
{
vim_free(script);
return;
}
if (perl_interp == NULL)
{
#ifdef DYNAMIC_PERL
if (!perl_enabled(TRUE))
{
EMSG(_(e_noperl));
vim_free(script);
return;
}
#endif
perl_init();
}
{
dSP;
ENTER;
SAVETMPS;
if (script == NULL)
sv = newSVpv((char *)eap->arg, 0);
else
{
sv = newSVpv(script, 0);
vim_free(script);
}
#ifdef HAVE_SANDBOX
if (sandbox)
{
# ifndef MAKE_TEST /* avoid a warning for unreachable code */
if ((safe = perl_get_sv( "VIM::safe", FALSE )) == NULL || !SvTRUE(safe))
EMSG(_("E299: Perl evaluation forbidden in sandbox without the Safe module"));
else
# endif
{
PUSHMARK(SP);
XPUSHs(safe);
XPUSHs(sv);
PUTBACK;
perl_call_method("reval", G_DISCARD);
}
}
else
#endif
perl_eval_sv(sv, G_DISCARD | G_NOARGS);
SvREFCNT_dec(sv);
err = SvPV(GvSV(PL_errgv), length);
FREETMPS;
LEAVE;
if (!length)
return;
msg_split((char_u *)err, highlight_attr[HLF_E]);
return;
}
}
static int
replace_line(line, end)
linenr_T *line, *end;
{
char *str;
if (SvOK(GvSV(PL_defgv)))
{
str = SvPV(GvSV(PL_defgv), PL_na);
ml_replace(*line, (char_u *)str, 1);
changed_bytes(*line, 0);
}
else
{
ml_delete(*line, FALSE);
deleted_lines_mark(*line, 1L);
--(*end);
--(*line);
}
return OK;
}
/*
* ":perldo".
*/
void
ex_perldo(eap)
exarg_T *eap;
{
STRLEN length;
SV *sv;
char *str;
linenr_T i;
if (bufempty())
return;
if (perl_interp == NULL)
{
#ifdef DYNAMIC_PERL
if (!perl_enabled(TRUE))
{
EMSG(_(e_noperl));
return;
}
#endif
perl_init();
}
{
dSP;
length = strlen((char *)eap->arg);
sv = newSV(length + sizeof("sub VIM::perldo {") - 1 + 1);
sv_setpvn(sv, "sub VIM::perldo {", sizeof("sub VIM::perldo {") - 1);
sv_catpvn(sv, (char *)eap->arg, length);
sv_catpvn(sv, "}", 1);
perl_eval_sv(sv, G_DISCARD | G_NOARGS);
SvREFCNT_dec(sv);
str = SvPV(GvSV(PL_errgv), length);
if (length)
goto err;
if (u_save(eap->line1 - 1, eap->line2 + 1) != OK)
return;
ENTER;
SAVETMPS;
for (i = eap->line1; i <= eap->line2; i++)
{
sv_setpv(GvSV(PL_defgv), (char *)ml_get(i));
PUSHMARK(sp);
perl_call_pv("VIM::perldo", G_SCALAR | G_EVAL);
str = SvPV(GvSV(PL_errgv), length);
if (length)
break;
SPAGAIN;
if (SvTRUEx(POPs))
{
if (replace_line(&i, &eap->line2) != OK)
{
PUTBACK;
break;
}
}
PUTBACK;
}
FREETMPS;
LEAVE;
check_cursor();
update_screen(NOT_VALID);
if (!length)
return;
err:
msg_split((char_u *)str, highlight_attr[HLF_E]);
return;
}
}
#ifndef FEAT_WINDOWS
int win_valid(win_T *w) { return TRUE; }
int win_count() { return 1; }
win_T *win_find_nr(int n) { return curwin; }
#endif
XS(XS_VIM_Msg);
XS(XS_VIM_SetOption);
XS(XS_VIM_DoCommand);
XS(XS_VIM_Eval);
XS(XS_VIM_Buffers);
XS(XS_VIM_Windows);
XS(XS_VIWIN_DESTROY);
XS(XS_VIWIN_Buffer);
XS(XS_VIWIN_SetHeight);
XS(XS_VIWIN_Cursor);
XS(XS_VIBUF_DESTROY);
XS(XS_VIBUF_Name);
XS(XS_VIBUF_Number);
XS(XS_VIBUF_Count);
XS(XS_VIBUF_Get);
XS(XS_VIBUF_Set);
XS(XS_VIBUF_Delete);
XS(XS_VIBUF_Append);
XS(boot_VIM);
static void
xs_init(pTHX)
{
char *file = __FILE__;
/* DynaLoader is a special case */
newXS("DynaLoader::boot_DynaLoader", boot_DynaLoader, file);
newXS("VIM::bootstrap", boot_VIM, file);
}
typedef win_T * VIWIN;
typedef buf_T * VIBUF;
MODULE = VIM PACKAGE = VIM
void
Msg(text, hl=NULL)
char *text;
char *hl;
PREINIT:
int attr;
int id;
PPCODE:
if (text != NULL)
{
attr = 0;
if (hl != NULL)
{
id = syn_name2id((char_u *)hl);
if (id != 0)
attr = syn_id2attr(id);
}
msg_split((char_u *)text, attr);
}
void
SetOption(line)
char *line;
PPCODE:
if (line != NULL)
do_set((char_u *)line, 0);
update_screen(NOT_VALID);
void
DoCommand(line)
char *line;
PPCODE:
if (line != NULL)
do_cmdline_cmd((char_u *)line);
void
Eval(str)
char *str;
PREINIT:
char_u *value;
PPCODE:
value = eval_to_string((char_u *)str, (char_u **)0, TRUE);
if (value == NULL)
{
XPUSHs(sv_2mortal(newSViv(0)));
XPUSHs(sv_2mortal(newSVpv("", 0)));
}
else
{
XPUSHs(sv_2mortal(newSViv(1)));
XPUSHs(sv_2mortal(newSVpv((char *)value, 0)));
vim_free(value);
}
void
Buffers(...)
PREINIT:
buf_T *vimbuf;
int i, b;
PPCODE:
if (items == 0)
{
if (GIMME == G_SCALAR)
{
i = 0;
for (vimbuf = firstbuf; vimbuf; vimbuf = vimbuf->b_next)
++i;
XPUSHs(sv_2mortal(newSViv(i)));
}
else
{
for (vimbuf = firstbuf; vimbuf; vimbuf = vimbuf->b_next)
XPUSHs(newBUFrv(newSV(0), vimbuf));
}
}
else
{
for (i = 0; i < items; i++)
{
SV *sv = ST(i);
if (SvIOK(sv))
b = SvIV(ST(i));
else
{
char_u *pat;
STRLEN len;
pat = (char_u *)SvPV(sv, len);
++emsg_off;
b = buflist_findpat(pat, pat+len, FALSE, FALSE);
--emsg_off;
}
if (b >= 0)
{
vimbuf = buflist_findnr(b);
if (vimbuf)
XPUSHs(newBUFrv(newSV(0), vimbuf));
}