1# -*- coding: utf-8 -*-
2#--------------------------------------------------------------------------
3# perl-test-sub-prototypes.pl
4#--------------------------------------------------------------------------
5# compiled all relevant subroutine prototype test cases
6#
7#--------------------------------------------------------------------------
8# Kein-Hong Man <keinhong@gmail.com> Public Domain
9#--------------------------------------------------------------------------
10# 20151227	initial document
11#--------------------------------------------------------------------------
12
13#--------------------------------------------------------------------------
14# test cases for sub syntax scanner
15#--------------------------------------------------------------------------
16# sub syntax: simple and with added module notation
17#--------------------------------------------------------------------------
18
19sub fish($) { 123; }
20sub fish::chips($) { 123; }			# module syntax
21sub fish::chips::sauce($) { 123; }		# multiple module syntax
22
23sub fish :: chips  ::		sauce ($) { 123; }	# added whitespace
24
25sub fish :: # embedded comment
26chips 	# embedded comment
27 :: sauce ($) { 123; }
28
29sub fish :: ($) { 123; }	# incomplete or bad syntax examples
30sub fish :: 123 ($) { 123; }
31sub fish :: chips 123 ($) { 123; }
32sub 123 ($) { 123; }
33
34#--------------------------------------------------------------------------
35# sub syntax: prototype attributes
36#--------------------------------------------------------------------------
37
38sub fish:prototype($) { 123; }
39sub fish : prototype	($) { 123; }		# added whitespace
40
41sub fish:salted($) { 123; }	# wrong attribute example (must use 'prototype')
42sub fish :  123($) { 123; }	# illegal attribute
43sub fish:prototype:salted($) { 123; }	# wrong 'prototype' position
44sub fish:salted salt:prototype($) { 123; }	# wrong attribute syntax
45
46sub fish:const:prototype($) { 123; }		# extra attributes
47sub fish:const:lvalue:prototype($) { 123; }
48sub fish:const:prototype($):lvalue{ 123; }	# might be legal too
49sub fish  :const	:prototype($) { 123; }	# extra whitespace
50
51sub fish  :const	# embedded comment: a constant sub
52:prototype		# embedded comment
53($) { 123; }
54
55#--------------------------------------------------------------------------
56# sub syntax: mixed
57#--------------------------------------------------------------------------
58
59sub fish::chips:prototype($) { 123; }
60sub fish::chips::sauce:prototype($) { 123; }
61sub fish  ::chips  ::sauce	:prototype($) { 123; }	# +whitespace
62
63sub fish::chips::sauce:const:prototype($) { 123; }
64sub fish::chips::sauce	:const	:prototype($) { 123; }	# +whitespace
65
66sub fish		# embedded comment
67::chips	::sauce		# embedded comment
68  : const		# embedded comment
69	: prototype ($) { 123; }
70
71# wrong syntax examples, parentheses must follow ':prototype'
72sub fish :prototype :const ($) { 123;}
73sub fish :prototype ::chips ($) { 123;}
74
75#--------------------------------------------------------------------------
76# perl-test-5200delta.pl
77#--------------------------------------------------------------------------
78# More consistent prototype parsing
79#--------------------------------------------------------------------------
80# - whitespace now allowed, lexer now allows spaces or tabs
81
82sub foo ( $ $ ) {}
83sub foo ( 			 ) {}		# spaces/tabs empty
84sub foo (  *  ) {}
85sub foo (@	) {}
86sub foo (	%) {}
87
88# untested, should probably be \[ but scanner does not check this for now
89sub foo ( \ [ $ @ % & * ] ) {}
90
91#--------------------------------------------------------------------------
92# perl-test-5140delta.pl
93#--------------------------------------------------------------------------
94# new + prototype character, acts like (\[@%])
95#--------------------------------------------------------------------------
96
97# these samples work as before
98sub mylink ($$)          # mylink $old, $new
99sub myvec ($$$)          # myvec $var, $offset, 1
100sub myindex ($$;$)       # myindex &getstring, "substr"
101sub mysyswrite ($$$;$)   # mysyswrite $buf, 0, length($buf) - $off, $off
102sub myreverse (@)        # myreverse $a, $b, $c
103sub myjoin ($@)          # myjoin ":", $a, $b, $c
104sub myopen (*;$)         # myopen HANDLE, $name
105sub mypipe (**)          # mypipe READHANDLE, WRITEHANDLE
106sub mygrep (&@)          # mygrep { /foo/ } $a, $b, $c
107sub myrand (;$)          # myrand 42
108sub mytime ()            # mytime
109
110# backslash group notation to specify more than one allowed argument type
111sub myref (\[$@%&*]) {}
112
113sub mysub (_)            # underscore can be optionally used FIXED 20151211
114
115# these uses the new '+' prototype character
116sub mypop (+)            # mypop @array
117sub mysplice (+$$@)      # mysplice @array, 0, 2, @pushme
118sub mykeys (+)           # mykeys %{$hashref}
119
120#--------------------------------------------------------------------------
121# perl-test-5200delta.pl
122#--------------------------------------------------------------------------
123# Experimental Subroutine signatures (mostly works)
124#--------------------------------------------------------------------------
125# INCLUDED FOR COMPLETENESS ONLY
126# IMPORTANT NOTE the subroutine prototypes lexing implementation has
127# no effect on subroutine signature syntax highlighting
128
129# subroutine signatures mostly looks fine except for the @ and % slurpy
130# notation which are highlighted as operators (all other parameters are
131# highlighted as vars of some sort), a minor aesthetic issue
132
133use feature 'signatures';
134
135sub foo ($left, $right) {		# mandatory positional parameters
136    return $left + $right;
137}
138sub foo ($first, $, $third) {		# ignore second argument
139    return "first=$first, third=$third";
140}
141sub foo ($left, $right = 0) {		# optional parameter with default value
142    return $left + $right;
143}
144my $auto_id = 0;			# default value expression, evaluated if default used only
145sub foo ($thing, $id = $auto_id++) {
146    print "$thing has ID $id";
147}
148sub foo ($first_name, $surname, $nickname = $first_name) {	# 3rd parm may depend on 1st parm
149    print "$first_name $surname is known as \"$nickname\"";
150}
151sub foo ($thing, $ = 1) {		# nameless default parameter
152    print $thing;
153}
154sub foo ($thing, $=) {			# (this does something, I'm not sure what...)
155    print $thing;
156}
157sub foo ($filter, @inputs) {		# additional arguments (slurpy parameter)
158    print $filter->($_) foreach @inputs;
159}
160sub foo ($thing, @) {			# nameless slurpy parameter FAILS for now
161    print $thing;
162}
163sub foo ($filter, %inputs) {		# slurpy parameter, hash type
164    print $filter->($_, $inputs{$_}) foreach sort keys %inputs;
165}
166sub foo ($thing, %) {			# nameless slurpy parm, hash type FAILS for now
167    print $thing;
168}
169sub foo () {				# empty signature no arguments (styled as prototype)
170    return 123;
171}
172
173#--------------------------------------------------------------------------
174# perl-test-5200delta.pl
175#--------------------------------------------------------------------------
176# subs now take a prototype attribute
177#--------------------------------------------------------------------------
178
179sub foo :prototype($) { $_[0] }
180
181sub foo :prototype($$) ($left, $right) {
182    return $left + $right;
183}
184
185sub foo : prototype($$){}		# whitespace allowed
186
187# additional samples from perl-test-cases.pl with ':prototype' added:
188sub mylink :prototype($$) {}		sub myvec :prototype($$$) {}
189sub myindex :prototype($$;$) {}		sub mysyswrite :prototype($$$;$) {}
190sub myreverse :prototype(@) {}		sub myjoin :prototype($@) {}
191sub mypop :prototype(\@) {}		sub mysplice :prototype(\@$$@) {}
192sub mykeys :prototype(\%) {}		sub myopen :prototype(*;$) {}
193sub mypipe :prototype(**) {}		sub mygrep :prototype(&@) {}
194sub myrand :prototype($) {}		sub mytime :prototype() {}
195# backslash group notation to specify more than one allowed argument type
196sub myref :prototype(\[$@%&*]) {}
197
198# additional attributes may complicate scanning for prototype syntax,
199# for example (from https://metacpan.org/pod/perlsub):
200# Lvalue subroutines
201
202my $val;
203sub canmod : lvalue {
204    $val;  # or:  return $val;
205}
206canmod() = 5;   # assigns to $val
207
208#--------------------------------------------------------------------------
209# perl-test-5220delta.pl
210#--------------------------------------------------------------------------
211# New :const subroutine attribute
212#--------------------------------------------------------------------------
213
214my $x = 54321;
215*INLINED = sub : const { $x };
216$x++;
217
218# more examples of attributes
219# (not 5.22 stuff, but some general examples for study, useful for
220#  handling subroutine signature and subroutine prototype highlighting)
221
222sub foo : lvalue ;
223
224package X;
225sub Y::z : lvalue { 1 }
226
227package X;
228sub foo { 1 }
229package Y;
230BEGIN { *bar = \&X::foo; }
231package Z;
232sub Y::bar : lvalue ;
233
234# built-in attributes for subroutines:
235lvalue method prototype(..) locked const
236
237#--------------------------------------------------------------------------
238# end of test file
239#--------------------------------------------------------------------------
240