Quelle  plperl_opmask.pl

#!perl

# Copyright (c) 2021-2025, PostgreSQL Global Development Group

use strict;
use warnings FATAL => 'all';

use Opcode qw(opset opset_to_ops opdesc);

my $plperl_opmask_h = shift
  or die "Usage: $0 <output_filename.h>\n";

my $plperl_opmask_tmp = $plperl_opmask_h . "tmp";
END { unlink $plperl_opmask_tmp }

open my $fh, ">", "$plperl_opmask_tmp"
  or die "Could not write to $plperl_opmask_tmp: $!";

printf $fh "#define PLPERL_SET_OPMASK(opmask) \\\n";
printf $fh "  memset(opmask, 1, MAXO);\t/* disable all */ \\\n";
printf $fh "  /* then allow some... */                       \\\n";

my @allowed_ops = (

 # basic set of opcodes
 qw[:default :base_math !:base_io sort time],

 # require is safe because we redirect the opcode
 # entereval is safe as the opmask is now permanently set
 # caller is safe because the entire interpreter is locked down
 qw[require entereval caller],

 # These are needed for utf8_heavy.pl:
 # dofile is safe because we redirect the opcode like require above
 # print is safe because the only writable filehandles are STDOUT & STDERR
 # prtf (printf) is safe as it's the same as print + sprintf
 qw[dofile print prtf],

 # Disallow these opcodes that are in the :base_orig optag
 # (included in :default) but aren't considered sufficiently safe
 qw[!dbmopen !setpgrp !setpriority],

 # custom is not deemed a likely security risk as it can't be generated from
 # perl so would only be seen if the DBA had chosen to load a module that
 # used it. Even then it's unlikely to be seen because it's typically
 # generated by compiler plugins that operate after PL_op_mask checks.
 # But we err on the side of caution and disable it
 qw[!custom],);

printf $fh "  /* ALLOWED: @allowed_ops */ \\\n";

foreach my $opname (opset_to_ops(opset(@allowed_ops)))
{
 printf $fh qq{  opmask[OP_%-12s] = 0;\t/* %s */ \\\n},
   uc($opname), opdesc($opname);
}
printf $fh "        /* end */\n";

close $fh
  or die "Error closing $plperl_opmask_tmp: $!";

rename $plperl_opmask_tmp, $plperl_opmask_h
  or die "Error renaming $plperl_opmask_tmp to $plperl_opmask_h: $!";

exit 0;