1#!perl
2
3# Copyright (c) 2021, PostgreSQL Global Development Group
4
5use strict;
6use warnings;
7
8use Opcode qw(opset opset_to_ops opdesc);
9
10my $plperl_opmask_h = shift
11  or die "Usage: $0 <output_filename.h>\n";
12
13my $plperl_opmask_tmp = $plperl_opmask_h . "tmp";
14END { unlink $plperl_opmask_tmp }
15
16open my $fh, ">", "$plperl_opmask_tmp"
17  or die "Could not write to $plperl_opmask_tmp: $!";
18
19printf $fh "#define PLPERL_SET_OPMASK(opmask) \\\n";
20printf $fh "  memset(opmask, 1, MAXO);\t/* disable all */ \\\n";
21printf $fh "  /* then allow some... */                       \\\n";
22
23my @allowed_ops = (
24
25	# basic set of opcodes
26	qw[:default :base_math !:base_io sort time],
27
28	# require is safe because we redirect the opcode
29	# entereval is safe as the opmask is now permanently set
30	# caller is safe because the entire interpreter is locked down
31	qw[require entereval caller],
32
33	# These are needed for utf8_heavy.pl:
34	# dofile is safe because we redirect the opcode like require above
35	# print is safe because the only writable filehandles are STDOUT & STDERR
36	# prtf (printf) is safe as it's the same as print + sprintf
37	qw[dofile print prtf],
38
39	# Disallow these opcodes that are in the :base_orig optag
40	# (included in :default) but aren't considered sufficiently safe
41	qw[!dbmopen !setpgrp !setpriority],
42
43	# custom is not deemed a likely security risk as it can't be generated from
44	# perl so would only be seen if the DBA had chosen to load a module that
45	# used it. Even then it's unlikely to be seen because it's typically
46	# generated by compiler plugins that operate after PL_op_mask checks.
47	# But we err on the side of caution and disable it
48	qw[!custom],);
49
50printf $fh "  /* ALLOWED: @allowed_ops */ \\\n";
51
52foreach my $opname (opset_to_ops(opset(@allowed_ops)))
53{
54	printf $fh qq{  opmask[OP_%-12s] = 0;\t/* %s */ \\\n},
55	  uc($opname), opdesc($opname);
56}
57printf $fh "								/* end */\n";
58
59close $fh
60  or die "Error closing $plperl_opmask_tmp: $!";
61
62rename $plperl_opmask_tmp, $plperl_opmask_h
63  or die "Error renaming $plperl_opmask_tmp to $plperl_opmask_h: $!";
64
65exit 0;
66