Diff -- /var/www/vhosts/3dshawn.com/repricer.3dshawn.com/MODS/Template.pm
Diff
/var/www/vhosts/3dshawn.com/repricer.3dshawn.com/MODS/Template.pm
added on local at 2026-07-01 21:47:15
Added
+571
lines
Removed
-0
lines
Context
0
unchanged
Blobs
from
to 1c37fd28e4c7
to 1c37fd28e4c7
Unified diff
Naive LCS-based line diff. Additions in emerald, deletions in rose. Both sides decompressed live from BLOB_STORE.| 1 | package MODS::Template; | |
| 2 | #====================================================================== | |
| 3 | # WebSTLs — templating engine. | |
| 4 | # | |
| 5 | # Reads a template file from TEMPLATES/ and converts custom tags into | |
| 6 | # real Perl, then runs the result to produce the rendered HTML. | |
| 7 | # | |
| 8 | # Tag reference: | |
| 9 | # $varname -> $tvars->{varname} | |
| 10 | # $var.sub.field -> $tvars->{var}->{sub}->{field} | |
| 11 | # [$var] -> same as $var, brackets stripped | |
| 12 | # [loop:@arr]...[/loop] | |
| 13 | # [if:cond]...[elsif:cond]...[else]...[/if] | |
| 14 | # [url:key] -> URL registry lookup | |
| 15 | # [ptag:N]...[/ptag:N] permission gates (DB-driven) | |
| 16 | # [area:name]...[/area:name] AJAX partials | |
| 17 | #====================================================================== | |
| 18 | use strict; | |
| 19 | ||
| 20 | # Optional dependencies — load each at runtime so a missing module | |
| 21 | # doesn't kill compilation. The original code paired `eval{require}` | |
| 22 | # with a `use` statement, but `use` fires at COMPILE time regardless of | |
| 23 | # the eval, which crashes the whole .cgi if the module file is absent. | |
| 24 | # Plain `require` here keeps these truly optional. | |
| 25 | ||
| 26 | my $url = {}; # default: empty hashref so [url:key] in templates never crashes | |
| 27 | if (eval { require MODS::Urls; 1 }) { | |
| 28 | my $getlist = MODS::Urls->new; | |
| 29 | $url = $getlist->urls() || {}; | |
| 30 | } | |
| 31 | ||
| 32 | my $db; | |
| 33 | if (eval { require MODS::DBConnect; 1 }) { | |
| 34 | $db = MODS::DBConnect->new; | |
| 35 | } | |
| 36 | ||
| 37 | my $config; | |
| 38 | if (eval { require MODS::Config; 1 }) { | |
| 39 | $config = MODS::Config->new; | |
| 40 | } | |
| 41 | ||
| 42 | my $database_name = $config ? $config->settings('database_name') : ''; | |
| 43 | ||
| 44 | #Variables | |
| 45 | my $newline_delimeter = '----NL----'; | |
| 46 | my $carriage_return_delimeter = '----CR----'; | |
| 47 | my $newline_delimeter_re = qr/\Q$newline_delimeter\E/; | |
| 48 | my $carriage_return_delimeter_re = qr/\Q$carriage_return_delimeter\E/; | |
| 49 | ||
| 50 | #Calling loop1 if you are inside of loop2 | |
| 51 | #$loop.variable_name | |
| 52 | #or | |
| 53 | #$loop1->{variable_name} | |
| 54 | ||
| 55 | #Calling outside of the loop back to the main set of variables in tvars | |
| 56 | #tvars.variable_name | |
| 57 | #or | |
| 58 | #$tvars->{variable_name} | |
| 59 | ||
| 60 | #Nested loops are always looking for looking to loop off of an array inside the previous loop, if you have a nested loop that is un-related to the loop it is nested within then call | |
| 61 | #back to the main variables using tvars | |
| 62 | #[loop:@tvars.main_array_name] | |
| 63 | ||
| 64 | #URLs are called with this command if it is in the MODS/URLs.pm module | |
| 65 | #[url:your_url_here] | |
| 66 | ||
| 67 | #Variables called like this | |
| 68 | #$var or $var.nested_var.nested_var or [$var] or [$var.nested_var.nested_var] | |
| 69 | ||
| 70 | #Loops | |
| 71 | #[loop:@array_of_hashrefs][/loop] | |
| 72 | ||
| 73 | #Logic statements, they can use all normal Perl operators such as < > = eq ne etc... | |
| 74 | #[if:$var][/if] | |
| 75 | #[elsif:$var1 eq 'test' && $var2 <= 5][/elseif] | |
| 76 | #[else][/else] | |
| 77 | ||
| 78 | ||
| 79 | sub new{ | |
| 80 | my($class, %args) = @_; | |
| 81 | my $self = bless({}, $class); | |
| 82 | ||
| 83 | return $self; | |
| 84 | } | |
| 85 | ||
| 86 | sub rebuild_variable{ | |
| 87 | #Converts template variables into real live Perl variables | |
| 88 | #Example: $tvars.data.user_name turns into $tvars->{data}->{user_name} | |
| 89 | my $variable = shift; | |
| 90 | ||
| 91 | my @pieces = split(/\./, $variable); | |
| 92 | ||
| 93 | my $new_variable; | |
| 94 | foreach my $piece(@pieces){ | |
| 95 | if(!$new_variable){ | |
| 96 | $new_variable = $piece . '->'; | |
| 97 | }else{ | |
| 98 | $new_variable .= '{' . $piece . '}->'; | |
| 99 | } | |
| 100 | } | |
| 101 | ||
| 102 | chop($new_variable); #Remove the > | |
| 103 | chop($new_variable); #Remove the - | |
| 104 | ||
| 105 | return $new_variable; | |
| 106 | } | |
| 107 | ||
| 108 | sub template{ | |
| 109 | my ($self, $template, $tvars, $userinfo, $option) = @_; | |
| 110 | ||
| 111 | # Inject standard role-aware tvars so every template can gate | |
| 112 | # owner-only blocks with `[if:$is_owner]` / `[if:$is_team_member]` | |
| 113 | # without each CGI having to set them. Underscore-leading would be | |
| 114 | # more conventional but our [if:] resolver treats `$x` as the | |
| 115 | # whole symbol, so we keep the names plain. | |
| 116 | $tvars ||= {}; | |
| 117 | if ($userinfo && $userinfo->{user_id}) { | |
| 118 | my $is_team = ($userinfo->{owner_user_id}) ? 1 : 0; | |
| 119 | $tvars->{is_team_member} = $is_team; | |
| 120 | $tvars->{is_owner} = $is_team ? 0 : 1; | |
| 121 | } else { | |
| 122 | $tvars->{is_team_member} = 0; | |
| 123 | $tvars->{is_owner} = 0; | |
| 124 | } | |
| 125 | ||
| 126 | #Get the URLs from the software calling this module if the URLs were passed in | |
| 127 | $url = $userinfo->{system_config}->{url} if $userinfo->{system_config}; | |
| 128 | ||
| 129 | #Get the template path from the software calling this module if it was passed in, otherwise use the normal path | |
| 130 | my $template_path = 'TEMPLATES'; | |
| 131 | $template_path = $userinfo->{system_config}->{config}->{'template_path'} if $userinfo->{system_config}; | |
| 132 | ||
| 133 | #Use the callers DB connection if passed in, otherwise we may open our own below | |
| 134 | my $dbh; | |
| 135 | my $close_dbh = 0; | |
| 136 | my $access_info = {}; | |
| 137 | ||
| 138 | #This area feature allows you to process only a piece of a template, used frequently with AJAX calls where you only want to return and update a piece/area of a page and not the whole page | |
| 139 | my $area_name = ".$1" if $option =~ m/area\:(\w+)/i; | |
| 140 | ||
| 141 | my @processed_parts; | |
| 142 | push @processed_parts, qq~my \$print_contents;~; | |
| 143 | ||
| 144 | #Get the template using slurp mode for speed | |
| 145 | #Prevent path traversal - block directory traversal and absolute paths | |
| 146 | if($template =~ m/\.\./ || $template =~ m/^\//){ | |
| 147 | return "Error: invalid template name"; | |
| 148 | } | |
| 149 | open(my $fh, '<', "$template_path/$template") || return "Error: template not found"; | |
| 150 | my $template_html = do { local $/; <$fh> }; | |
| 151 | close $fh; | |
| 152 | ||
| 153 | #Variables to track the opening and closing tags | |
| 154 | my @opened_tags; | |
| 155 | ||
| 156 | #Strip HTML comments before parsing. Template tags like [loop:] and | |
| 157 | #[if:] sitting inside <!-- ... --> would otherwise be wrongly read as | |
| 158 | #real directives, scrambling the bracket-nesting count and producing | |
| 159 | #malformed Perl. HTML comments aren't visible in output so dropping | |
| 160 | #them is harmless. | |
| 161 | $template_html =~ s/<!--.*?-->//gs; | |
| 162 | ||
| 163 | #Replace the newline chars until later so they don't get in the way, don't remove escaped ones though | |
| 164 | $template_html =~ s/\n/$newline_delimeter/g; | |
| 165 | $template_html =~ s/\r/$carriage_return_delimeter/g; | |
| 166 | ||
| 167 | ||
| 168 | #---------------------------------------------------------------------------------------------------------- | |
| 169 | #-Permission tag — [ptag:N]...[/ptag:N] gates content on permission_features.id N. | |
| 170 | # | |
| 171 | # Accepts numeric IDs OR slug names (preferred): | |
| 172 | # [ptag:edit_models]<button>Edit</button>[/ptag:edit_models] | |
| 173 | # [ptag:13]<button>Edit</button>[/ptag:13] (same thing) | |
| 174 | # | |
| 175 | # Lookup model (WebSTLs): | |
| 176 | # - users.permission_groups_id IS NULL -> owner / unconstrained. Every gate passes. | |
| 177 | # - users.permission_groups_id IS NOT NULL -> team member. Only the | |
| 178 | # feature ids listed in permission_groups.permission_features_ids | |
| 179 | # (CSV) pass; everything else is stripped to an HTML comment. | |
| 180 | # | |
| 181 | # The query joins permission_groups directly off the users row so a | |
| 182 | # single SELECT covers both cases (LEFT JOIN returns NULL for owners). | |
| 183 | # If the template uses any slug names we also pull the 28-row | |
| 184 | # permission_features map once and reuse it for every gate in this render. | |
| 185 | #---------------------------------------------------------------------------------------------------------- | |
| 186 | if($template_html =~ m/ptag:/i){ | |
| 187 | $dbh = $db->db_connect(); | |
| 188 | $close_dbh = 1; | |
| 189 | ||
| 190 | #Sanitize user input to numeric only to prevent SQL injection | |
| 191 | my $safe_user_id = $userinfo->{user_id} || 0; | |
| 192 | $safe_user_id =~ s/[^0-9]//g; | |
| 193 | $safe_user_id ||= 0; | |
| 194 | ||
| 195 | my $is_owner = 0; | |
| 196 | my $features_csv = ''; | |
| 197 | ||
| 198 | if ($safe_user_id) { | |
| 199 | my $sql = qq~SELECT u.permission_groups_id, pg.permission_features_ids | |
| 200 | FROM $database_name.users u | |
| 201 | LEFT JOIN $database_name.permission_groups pg | |
| 202 | ON pg.id = u.permission_groups_id AND pg.group_status='1' | |
| 203 | WHERE u.id = '$safe_user_id' | |
| 204 | LIMIT 1~; | |
| 205 | my $row = $db->db_readwrite($dbh, $sql, $ENV{SCRIPT_NAME}, __LINE__); | |
| 206 | ||
| 207 | if (!$row || !defined $row->{permission_groups_id} || $row->{permission_groups_id} eq '') { | |
| 208 | # Owner / unconstrained access | |
| 209 | $is_owner = 1; | |
| 210 | } else { | |
| 211 | $features_csv = $row->{permission_features_ids} || ''; | |
| 212 | } | |
| 213 | } else { | |
| 214 | # Anonymous / no userinfo -> treat as no access | |
| 215 | $is_owner = 0; | |
| 216 | } | |
| 217 | ||
| 218 | # Build slug -> id map only if a non-numeric ptag exists in the | |
| 219 | # template. Numeric-only templates skip this trip entirely. | |
| 220 | my %slug_to_id; | |
| 221 | if ($template_html =~ m/\[\s*ptag:[a-zA-Z_]/) { | |
| 222 | my @rows = $db->db_readwrite_multiple($dbh, qq~ | |
| 223 | SELECT id, slug FROM $database_name.permission_features | |
| 224 | ~, $ENV{SCRIPT_NAME}, __LINE__); | |
| 225 | foreach my $r (@rows) { $slug_to_id{$r->{slug}} = $r->{id}; } | |
| 226 | } | |
| 227 | ||
| 228 | $access_info = { permission_features_ids => $features_csv, is_owner => $is_owner }; | |
| 229 | ||
| 230 | while($template_html =~ s/\[\s{0,}\t{0,}ptag:(.*?)\](.*?)\[\/ptag:\1\]/[--$1--]/i){ | |
| 231 | my $ptag = $1; | |
| 232 | my $html_content = $2; | |
| 233 | ||
| 234 | # Resolve slug -> id if non-numeric. Unknown slug = deny. | |
| 235 | my $id = ($ptag =~ /^\d+$/) ? $ptag : ($slug_to_id{$ptag} || 0); | |
| 236 | my $allowed = $access_info->{is_owner} | |
| 237 | || ($id && ",$access_info->{permission_features_ids}," =~ m/,$id,/); | |
| 238 | if ($allowed) { | |
| 239 | $template_html =~ s/\[--\Q$ptag\E--\]/$html_content/; | |
| 240 | } else { | |
| 241 | $template_html =~ s/\[--\Q$ptag\E--\]/\<\!-- $ptag:no access --\>/; | |
| 242 | } | |
| 243 | } | |
| 244 | } | |
| 245 | #---------------------------------------------------------------------------------------------------------- | |
| 246 | #---------------------------------------------------------------------------------------------------------- | |
| 247 | ||
| 248 | ||
| 249 | #---------------------------------------------------------------------------------------------------------- | |
| 250 | #-Area called, this will find and remove everything except the area called -------------------------------- | |
| 251 | if($area_name){ | |
| 252 | #If only the area was suppose to be loaded then lets get rid of everything else | |
| 253 | my $tag = $area_name; | |
| 254 | $tag =~ s/^\.//; | |
| 255 | ||
| 256 | #Get the contents from between the area tags | |
| 257 | $template_html =~ s/.*?\[area\(\w{0,}\)\:$tag\](.*?)\[\/area\:$tag\].*/$1/i; | |
| 258 | if(!$1){ | |
| 259 | #If the tag wasn't found then try looking for the same tags without the (flags) | |
| 260 | $template_html =~ s/.*?\[area\:$tag\](.*?)\[\/area\:$tag\].*/$1/i; | |
| 261 | } | |
| 262 | ||
| 263 | #First tag: remove the closing HTML comment code if the area tags were hidden inside of a comment | |
| 264 | $template_html =~ s/^\s{0,}\t{0,}\-\-\>//i; | |
| 265 | #Second tag: remove the closing HTML comment code if the area tags were hidden inside of a comment | |
| 266 | $template_html =~ s/\s{0,}\t{0,}\-\-\>$//i; | |
| 267 | }else{ | |
| 268 | #Find all area tags NOT currently being requested to see what we should do with them | |
| 269 | while($template_html =~ s/(\[area)\((\w{0,})\)(\:)(\w+)(\])/$1$3$4$5/i || $template_html =~ m/\[area\:(\w+)\]/i){ | |
| 270 | my $flag = $2; | |
| 271 | ||
| 272 | my $tag; | |
| 273 | if($flag eq 'hide'){ | |
| 274 | $tag = $4; | |
| 275 | #Remove the tags and area that tags surround to hide this until it is requested | |
| 276 | #Code from before I added te comment removing code# $template_html =~ s/\[area\:$tag\].*?\[\/area\:$tag\]//i; | |
| 277 | $template_html =~ s/(\<\!--)?\s{0,}\t{0,}\[area\:$tag\]\s{0,}\t{0,}(--\>)?.*?(\<\!--)?\s{0,}\t{0,}\[\/area\:$tag\]\s{0,}\t{0,}(--\>)?//i; | |
| 278 | }else{ | |
| 279 | $tag = $1; | |
| 280 | #Just remove the tags only from the HTML, just the template codes leaving clean HTML | |
| 281 | #Code from before I added te comment removing code# $template_html =~ s/(\[area\:$tag\])(.*?)(\[\/area\:$tag\])/$2/i; | |
| 282 | $template_html =~ s/(\<\!--)?\s{0,}\t{0,}(\[area\:$tag\])\s{0,}\t{0,}(--\>)?(.*?)(\<\!--)?\s{0,}\t{0,}(\[\/area\:$tag\])\s{0,}\t{0,}(--\>)?/$4/i; | |
| 283 | } | |
| 284 | #Debug: print qq~TAG FOUND: $tag<br>~; | |
| 285 | } | |
| 286 | } | |
| 287 | #---------------------------------------------------------------------------------------------------------- | |
| 288 | #---------------------------------------------------------------------------------------------------------- | |
| 289 | ||
| 290 | #Replace all global variables in the template, non nested variables both inside and outside of loops | |
| 291 | #Convert template variable into Perl variable formats, we are only converting ones that start with $tvars, this will call the subroutine called rebuild_variable in the second part of the regex where the replace happens | |
| 292 | # | |
| 293 | #The key portion uses \w+ (no dots) so a bare reference like | |
| 294 | #$loop1.image_idx.webp resolves $loop1->{image_idx} and leaves .webp | |
| 295 | #as literal text in the output. For genuine deep-nested access, use | |
| 296 | #the bracket form: [$var.sub.field] -- that explicitly delimits the | |
| 297 | #full path before any trailing literal text. | |
| 298 | $template_html =~ s|\[?(?<!\\)\$tvars\.([\w\.]+)\]?|'$tvars->{' . join('}->{', split(/\./, $1)) . '}'|ge; | |
| 299 | $template_html =~ s|\[(\$loop\d+)\.([\w\.]+)\]|$1 . join('', map { '->{' . $_ . '}' } split(/\./, $2))|ge; | |
| 300 | $template_html =~ s|(\$loop\d+)\.(\w+)|$1\->{$2}|g; | |
| 301 | ||
| 302 | my $opened_depth = 0; #Used for tracking nested loops as well as indenting code in debug mode | |
| 303 | my $loop_open=0; #Track open loops so we can replace the variables | |
| 304 | #Get a list of all opening tags so we know the order to close them in | |
| 305 | while($template_html =~ m~(.*?)?((\[(if|elsif|else|loop):?.*?\])|(\[\/(if|elsif|else|loop)\]))|(.*)~cgi){ | |
| 306 | my $open = $3 if $3; | |
| 307 | my $close = $5 if $5; | |
| 308 | ||
| 309 | #Save the data we pulled out for later processing and putting back in place | |
| 310 | push(@opened_tags, $open) if $open; | |
| 311 | ||
| 312 | #Opening tag, depth tracks how nested this tag is, add one | |
| 313 | $opened_depth++ if $open; | |
| 314 | ||
| 315 | #Debug - prints out all of the opened and closed tags with indentation for easy view | |
| 316 | #print ' 'x($opened_depth + 1) . "opened: $open\n" if $open; | |
| 317 | #print ' 'x($opened_depth + 1) . "closed: $close\n" if $close; | |
| 318 | ||
| 319 | #----------------------------------------------------------------------------------------------------------------- | |
| 320 | #Now convert the HTML template tags to Perl code | |
| 321 | my $html = $1.$7; #Copy for editing | |
| 322 | ||
| 323 | #Creating temporary copy, removing newline and carriage return delimeters so we can test if there is still a value | |
| 324 | my $tmp_html = $1.$7; | |
| 325 | $tmp_html =~ s/$newline_delimeter_re//g; | |
| 326 | $tmp_html =~ s/$carriage_return_delimeter_re//g; | |
| 327 | ||
| 328 | if($loop_open > 0){ | |
| 329 | ################################################################################################################## | |
| 330 | ### Replace any variables inside of loops ######################################################################## | |
| 331 | ||
| 332 | #----------------------------------------------------------------------------------------------------------------- | |
| 333 | #Replace variables with [] brackets and without such as [$var] and [$var.var2] and [$var.var2.var3] etc... and $var and $var.var2 and $var.var2.var3 | |
| 334 | while($html =~ m~\[?(?<!\\)\$(?!tvars->)(?!loop\d{0,}->)([\w\.{0,}]+)\]?~ci){ | |
| 335 | my $var_found = $1; | |
| 336 | my @nested = split(/\./, $var_found); | |
| 337 | my $variable_design; | |
| 338 | foreach my $nested(@nested){ | |
| 339 | if(!$variable_design){ | |
| 340 | $variable_design = "\$loop$loop_open-\>{$nested}"; | |
| 341 | }else{ | |
| 342 | $variable_design .= "-\>{$nested}"; | |
| 343 | } | |
| 344 | } | |
| 345 | $html =~ s/\[?\$$var_found\]?/$variable_design/; #Replace the variables in the open tags | |
| 346 | } | |
| 347 | #----------------------------------------------------------------------------------------------------------------- | |
| 348 | ||
| 349 | #----------------------------------------------------------------------------------------------------------------- | |
| 350 | #Take the loop array name and convert it to the read-array variable format. Three roots are recognised: | |
| 351 | # [loop:@plain_field] -> @{$loopN->{plain_field}} (current loop's row -- N = $loop_open) | |
| 352 | # [loop:@tvars.foo.bar] -> @{$tvars->{foo}->{bar}} (escape back to top-level tvars) | |
| 353 | # [loop:@loop1.foo.bar] -> @{$loop1->{foo}->{bar}} (reach back to a specific outer loop's iter var) | |
| 354 | #The loopN form was previously mishandled as a hash-key segment on top of the CURRENT $loopN itself, | |
| 355 | #producing @{$loopN->{loop1}->{foo}} -- silently empty -- which broke every nested @loopN.field template. | |
| 356 | if($open =~ m/\@((\w+|\.+)+)/){ | |
| 357 | my $var_found = $1; | |
| 358 | my @nested = split(/\./, $1); | |
| 359 | my $head; | |
| 360 | if ($nested[0] =~ m/^tvars$/i) { | |
| 361 | shift(@nested); | |
| 362 | $head = '$tvars'; | |
| 363 | } elsif ($nested[0] =~ m/^loop\d+$/i) { | |
| 364 | $head = '$' . shift(@nested); | |
| 365 | } else { | |
| 366 | $head = '$loop' . $loop_open; | |
| 367 | } | |
| 368 | my $variable_design = "\@{$head"; | |
| 369 | foreach my $nested(@nested){ | |
| 370 | $variable_design .= "-\>{$nested}"; | |
| 371 | } | |
| 372 | $open =~ s/\@((\w+|\.+)+)/$variable_design\}/; #Replace the variables in the open tags | |
| 373 | } | |
| 374 | #----------------------------------------------------------------------------------------------------------------- | |
| 375 | ||
| 376 | #----------------------------------------------------------------------------------------------------------------- | |
| 377 | #Deal with variables in if/elsif conditions | |
| 378 | if($open =~ m/(if|elsif).*?\$(?!tvars->)([\w\.]+)/){ | |
| 379 | while($open =~ m/\$(?!tvars->)(?!loop\d+->)([\w\.]+)/ci){ | |
| 380 | my $var_found = $1; | |
| 381 | my @nested = split(/\./, $1); | |
| 382 | my $variable_design; | |
| 383 | foreach my $nested(@nested){ | |
| 384 | if(!$variable_design){ | |
| 385 | $variable_design = "\$loop$loop_open-\>{$nested}"; | |
| 386 | }else{ | |
| 387 | $variable_design .= "-\>{$nested}"; | |
| 388 | } | |
| 389 | } | |
| 390 | $open =~ s/\$$var_found/$variable_design/; #Replace the variables in the open tags | |
| 391 | } | |
| 392 | } | |
| 393 | #----------------------------------------------------------------------------------------------------------------- | |
| 394 | ||
| 395 | #The HTML is about to be wrapped in qq~...~ to form the | |
| 396 | #Perl code we eval. A literal ~ in the HTML would close the | |
| 397 | #qq early and leak HTML into code position, which then | |
| 398 | #cascades into "Unrecognized character" errors when bytes | |
| 399 | #spill out of string context. Escape it first so qq~\~~ | |
| 400 | #renders as a literal ~ in the output. Also escape @ before | |
| 401 | #identifier chars so CSS rules (@media, @keyframes) and email | |
| 402 | #addresses (support@taskforge.com) don't get parsed as array | |
| 403 | #interpolation -- that fires "Not an ARRAY reference" at the | |
| 404 | #closing brace of the surrounding block. | |
| 405 | my $safe_html = $html; | |
| 406 | $safe_html =~ s/~/\\~/g; | |
| 407 | $safe_html =~ s/\@(?=[A-Za-z_\{\$])/\\\@/g; | |
| 408 | push @processed_parts, qq~\$print_contents .= qq\~$safe_html\~\;~ if $tmp_html =~ m/[!-~]/; | |
| 409 | ||
| 410 | ### Replace all of the variables inside this loop ################################################################ | |
| 411 | ################################################################################################################## | |
| 412 | }else{ | |
| 413 | ################################################################################################################## | |
| 414 | ### Replace any variables outside of loops ####################################################################### | |
| 415 | ||
| 416 | #----------------------------------------------------------------------------------------------------------------- | |
| 417 | #Replace variables with [] brackets and without such as [$var] and [$var.var2] and [$var.var2.var3] etc... and $var and $var.var2 and $var.var2.var3 | |
| 418 | while($html =~ m~\[?(?<!\\)\$(?!tvars->)(?!\{)([\w\.]+)\]?~ci){ | |
| 419 | my $var_found = $1; | |
| 420 | my @nested = split(/\./, $var_found); | |
| 421 | my $variable_design; | |
| 422 | foreach my $nested(@nested){ | |
| 423 | if(!$variable_design){ | |
| 424 | $variable_design = "\$tvars-\>{$nested}"; | |
| 425 | }else{ | |
| 426 | $variable_design .= "-\>{$nested}"; | |
| 427 | } | |
| 428 | } | |
| 429 | $html =~ s/\[?\$$var_found\]?/$variable_design/; #Replace the variables in the open tags | |
| 430 | } | |
| 431 | #----------------------------------------------------------------------------------------------------------------- | |
| 432 | ||
| 433 | #----------------------------------------------------------------------------------------------------------------- | |
| 434 | #Take the loop array name and convert it to the read array variable format such as [loop:@names.first] would become @{$namesDeal}->{first} | |
| 435 | if($open =~ m/\@((\w+|\.+)+)/){ | |
| 436 | my $var_found = $1; | |
| 437 | my @nested = split(/\./, $1); | |
| 438 | my $variable_design; | |
| 439 | foreach my $nested(@nested){ | |
| 440 | if(!$variable_design){ | |
| 441 | $variable_design = "\@{\$tvars-\>{$nested}}"; | |
| 442 | }else{ | |
| 443 | $variable_design .= "-\>{$nested}"; | |
| 444 | } | |
| 445 | } | |
| 446 | $open =~ s/\@((\w+|\.+)+)/$variable_design/; #Replace the variables in the open tags | |
| 447 | } | |
| 448 | #----------------------------------------------------------------------------------------------------------------- | |
| 449 | ||
| 450 | #----------------------------------------------------------------------------------------------------------------- | |
| 451 | #Deal with variables in if/elsif conditions | |
| 452 | if($open =~ m/(if|elsif).*?\$(?!tvars->)([\w\.]+)/){ | |
| 453 | while($open =~ m/\$(?!tvars-\>)([\w\.]+)/ci){ | |
| 454 | my $var_found = $1; | |
| 455 | my @nested = split(/\./, $1); | |
| 456 | my $variable_design; | |
| 457 | foreach my $nested(@nested){ | |
| 458 | if(!$variable_design){ | |
| 459 | $variable_design = "\$tvars-\>{$nested}"; | |
| 460 | }else{ | |
| 461 | $variable_design .= "-\>{$nested}"; | |
| 462 | } | |
| 463 | } | |
| 464 | $open =~ s/\$$var_found/$variable_design/; #Replace the variables in the open tags | |
| 465 | } | |
| 466 | } | |
| 467 | #----------------------------------------------------------------------------------------------------------------- | |
| 468 | ||
| 469 | #Same escape pass as the in-loop branch -- see comment there | |
| 470 | #for the @media / email-address rationale. | |
| 471 | my $safe_html = $html; | |
| 472 | $safe_html =~ s/~/\\~/g; | |
| 473 | $safe_html =~ s/\@(?=[A-Za-z_\{\$])/\\\@/g; | |
| 474 | push @processed_parts, qq~\$print_contents .= qq\~$safe_html\~\;~ if $tmp_html =~ m/[!-~]/; | |
| 475 | ||
| 476 | ### Replace all of the variables outside this loop ############################################################### | |
| 477 | ################################################################################################################## | |
| 478 | } | |
| 479 | ||
| 480 | if($open){ | |
| 481 | #If a loop was opened them mark it here at the bottom, we don't want to modify the text found before the loop was opened, only after | |
| 482 | $loop_open++ if $open =~ m/\[loop/i; | |
| 483 | ||
| 484 | #Replace all template "opening" tags with actual Perl code | |
| 485 | my $tag = $open; | |
| 486 | $tag =~ s~\[(if|elsif):(.*?)\]~$1\($2\)\{~gi; #Replace all "if" and "elsif" tags | |
| 487 | $tag =~ s~\[else\]~else\{~gi; #Replace all "else" tags | |
| 488 | $tag =~ s~\[loop:(.*?)\]~foreach my \$loop$loop_open\($1\)\{~gi; #Replace all "loop" tags | |
| 489 | ||
| 490 | push @processed_parts, "$tag"; | |
| 491 | } | |
| 492 | ||
| 493 | if($close){ | |
| 494 | #Closing tag, depth tracks how nested this tag is, subtract one | |
| 495 | $opened_depth-- if $close; | |
| 496 | $loop_open-- if $close =~ m/\[\/loop/i; | |
| 497 | ||
| 498 | #Replace all template "closing" tags with actual Perl tags | |
| 499 | push @processed_parts, "}"; | |
| 500 | } | |
| 501 | #----------------------------------------------------------------------------------------------------------------- | |
| 502 | ||
| 503 | #Reset all of the regex vars with each loop pass we do to be safe | |
| 504 | my $vars =~ s/()()()()()()//; | |
| 505 | } | |
| 506 | ||
| 507 | #Join all parts into the final processed template string. Append an | |
| 508 | #explicit final-expression `$print_contents` so eval always returns the | |
| 509 | #accumulated string, even when the template ends inside an if/foreach | |
| 510 | #branch that didn't fire on this render. | |
| 511 | my $processed_template = join('', @processed_parts) . qq~;\$print_contents;~; | |
| 512 | ||
| 513 | #Replace all URLs in the template | |
| 514 | $processed_template =~ s|\[url\:(.*?)\]|$url->{$1}|ig; | |
| 515 | ||
| 516 | #Put back the newline and carriage return chars | |
| 517 | $processed_template =~ s/$newline_delimeter_re/\n/g; | |
| 518 | $processed_template =~ s/$carriage_return_delimeter_re/\r/g; | |
| 519 | ||
| 520 | #Close database connection only if we opened one | |
| 521 | $db->db_disconnect($dbh) if $close_dbh; | |
| 522 | ||
| 523 | #Run the new files code in memory and then return the results | |
| 524 | my $processed_template = &run_in_memory($processed_template, $tvars); | |
| 525 | } | |
| 526 | ||
| 527 | sub run_in_memory{ | |
| 528 | my $code = shift; | |
| 529 | our $tvars = shift; | |
| 530 | ||
| 531 | # Debug: APPEND tvars structure to disk for inspection | |
| 532 | eval { | |
| 533 | my $debug_path = '/var/www/vhosts/3dshawn.com/taskforge.3dshawn.com/_tvars_dump.txt'; | |
| 534 | if (open my $dh, '>>', $debug_path) { | |
| 535 | print $dh "\n===== run_in_memory call =====\n"; | |
| 536 | foreach my $k (sort keys %$tvars) { | |
| 537 | my $v = $tvars->{$k}; | |
| 538 | my $type = ref($v) || 'scalar'; | |
| 539 | my $val = (ref($v) eq 'ARRAY') ? '[' . scalar(@$v) . ' items]' | |
| 540 | : (ref($v) eq 'HASH') ? '{' . join(',', sort keys %$v) . '}' | |
| 541 | : (defined $v ? substr($v, 0, 60) : 'UNDEF'); | |
| 542 | print $dh "$k => $type :: $val\n"; | |
| 543 | } | |
| 544 | close $dh; | |
| 545 | } | |
| 546 | }; | |
| 547 | ||
| 548 | my $print_contents; | |
| 549 | { | |
| 550 | no strict; | |
| 551 | $print_contents = eval $code; | |
| 552 | } | |
| 553 | ||
| 554 | if($@){ | |
| 555 | my $err = $@; | |
| 556 | eval { | |
| 557 | my $path = '/var/www/vhosts/3dshawn.com/taskforge.3dshawn.com/_tmpl_dump.txt'; | |
| 558 | if (open my $fh, '>>', $path) { | |
| 559 | print $fh "\n========== ERR: $err\n"; | |
| 560 | my $ln = 0; | |
| 561 | foreach my $L (split /\n/, $code) { $ln++; print $fh sprintf('%4d: %s', $ln, $L), "\n"; } | |
| 562 | close $fh; | |
| 563 | } | |
| 564 | }; | |
| 565 | return "Template eval error: $err"; | |
| 566 | } | |
| 567 | ||
| 568 | return $print_contents; | |
| 569 | } | |
| 570 | ||
| 571 | 1; |