script.cc 3.48 KB
Newer Older
1
/*
Dorian Guillois's avatar
Dorian Guillois committed
2
** Copyright 2011-2013 Merethis
3
**
4
** This file is part of Centreon Perl Connector.
5
**
6
** Centreon Perl Connector is free software: you can redistribute it
7
8
9
10
** and/or modify it under the terms of the GNU Affero General Public
** License as published by the Free Software Foundation, either version
** 3 of the License, or (at your option) any later version.
**
11
** Centreon Perl Connector is distributed in the hope that it will be
12
13
14
15
16
** useful, but WITHOUT ANY WARRANTY; without even the implied warranty
** of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
** Affero General Public License for more details.
**
** You should have received a copy of the GNU Affero General Public
17
** License along with Centreon Perl Connector. If not, see
18
19
20
** <http://www.gnu.org/licenses/>.
*/

21
#include "com/centreon/connector/perl/embedded_perl.hh"
22

23
char const* const com::centreon::connector::perl::embedded_perl::_script =
24
25
26
27
28
29
30
31
32
33
34
  "#!/usr/bin/perl\n" \
  "\n" \
  "package Embed::Persistent;\n" \
  "\n" \
  "use Text::ParseWords qw(parse_line);\n" \
  "\n" \
  "our %Cache;\n" \
  "\n" \
  "use constant MTIME_IDX  => 0;\n" \
  "use constant HANDLE_IDX => 1;\n" \
  "\n" \
35
36
  "$| = 1;\n" \
  "\n" \
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
  "sub valid_package_name {\n" \
  "  my ($string) = @_;\n" \
  "  # First pass.\n" \
  "  $string =~ s/([^A-Za-z0-9\\/])/sprintf(\"_%2x\", unpack(\"C\", $1))/eg;\n" \
  "  # Second pass only for words starting with a digit.\n" \
  "  $string =~ s|/(\\d)|sprintf(\"/_%2x\", unpack(\"C\", $1))|eg;\n" \
  "  # Dress it up as a real package name.\n" \
  "  $string =~ s|/|::|g;\n" \
  "  return \"Embed\" . $string;\n" \
  "}\n" \
  "\n" \
  "sub eval_file {\n" \
  "  my ($filename) = @_;\n" \
  "  my $mtime = -M $filename;\n" \
  "  # Is plugin already compiled ?\n" \
  "  if (exists($Cache{$filename})\n" \
  "      && $Cache{$filename}[MTIME_IDX]\n" \
  "      && $Cache{$filename}[MTIME_IDX] <= $mtime) {\n" \
  "      return $Cache{$filename}[HANDLE_IDX];\n" \
  "  }\n" \
  "\n" \
  "  # Read Perl script.\n" \
  "  my $package = valid_package_name($filename);\n" \
  "  open(my $fh, \"<\", $filename)\n" \
  "    or die \"failed to open Perl file '$filename': $!\";\n" \
  "  my $sub;\n" \
  "  sysread $fh, $sub, -s $fh;\n" \
  "  close $fh;\n" \
Dorian Guillois's avatar
Dorian Guillois committed
65
  "  $sub =~ s/__END__/\\;}\n__END__/;\n" \
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
  "\n" \
  "  # Wrap the code into a subroutine.\n" \
  "  my $hndlr = <<EOSUB;\n" \
  "package $package;\n" \
  "sub subroutine {\n" \
  "  \\@ARGV = \\@_;\n" \
  "  local \\$^W = 1;\n" \
  "  $sub\n" \
  "}\n" \
  "EOSUB\n" \
  "\n" \
  "  # Ensure modified Perl plugins get recached properly.\n" \
  "  no strict 'refs';\n" \
  "  undef %{$package.'::'};\n" \
  "  use strict 'refs';\n" \
  "\n" \
  "  # Compile.\n" \
  "  eval $hndlr;\n" \
  "  if ($@) {\n" \
  "    chomp($@);\n" \
  "    die \"syntax error in '$filename': $@\";\n" \
  "  }\n" \
  "\n" \
  "  # Add script to cache.\n" \
  "  $Cache{$filename}[MTIME_IDX] = $mtime;\n" \
  "  no strict 'refs';\n" \
  "  return $Cache{$filename}[HANDLE_IDX] = *{ $package . '::subroutine' }{CODE} ;\n" \
  "}\n" \
  "\n" \
  "sub run_file {\n" \
  "  # Fetch arguments.\n" \
  "  my ($filename, $handle, $args) = @_;\n" \
  "\n" \
  "  # Parse arguments.\n" \
  "  my @parsed_args = (\"$filename\");\n" \
  "  push(@parsed_args, parse_line('\\s+', 0, $args));\n" \
  "\n" \
  "  # Run subroutine.\n" \
  "  my $res;\n" \
  "  eval { $res = $handle->(@parsed_args) };\n" \
  "  if ($@) {\n" \
  "    chomp($@);\n" \
  "    die \"could not run '$filename': $@\";\n" \
  "  }\n" \
  "  return ($res);\n" \
  "}\n";