1# UI::Primitive - Interchange configuration manager primitives 2 3# $Id: Primitive.pm,v 2.28 2008-04-10 22:26:12 docelic Exp $ 4 5# Copyright (C) 2002-2007 Interchange Development Group 6# Copyright (C) 1998-2002 Red Hat, Inc. 7 8# Authors: 9# Michael J. Heins <mikeh@perusion.net> 10# Stefan Hornburg <racke@linuxia.de> 11 12# This file is free software; you can redistribute it and/or modify it 13# under the terms of the GNU General Public License as published by the 14# Free Software Foundation; either version 2, or (at your option) any 15# later version. 16 17# This file is distributed in the hope that it will be 18# useful, but WITHOUT ANY WARRANTY; without even the implied warranty 19# of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU 20# General Public License for more details. 21 22# You should have received a copy of the GNU General Public License 23# along with this file; see the file COPYING. If not, write to the Free 24# Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. 25 26my($order, $label, %terms) = @_; 27 28package UI::Primitive; 29 30$VERSION = substr(q$Revision: 2.28 $, 10); 31 32$DEBUG = 0; 33 34use vars qw! 35 @EXPORT @EXPORT_OK 36 $VERSION $DEBUG 37 $DECODE_CHARS 38 !; 39 40use File::Find; 41use Exporter; 42use strict; 43no warnings qw(uninitialized numeric); 44use Vend::Util qw/errmsg/; 45$DECODE_CHARS = qq{&[<"\000-\037\177-\377}; 46 47@EXPORT = qw( 48 list_glob 49 list_images 50 list_pages 51 ui_acl_enabled 52 ui_check_acl 53 ); 54 55=head1 NAME 56 57Primitive.pm -- Interchange Configuration Manager Primitives 58 59=head1 SYNOPSIS 60 61display_directive %options; 62 63=head1 DESCRIPTION 64 65The Interchange UI is an interface to configure and administer Interchange catalogs. 66 67=cut 68 69my $ui_safe = new Safe; 70$ui_safe->untrap(@{$Global::SafeUntrap}); 71 72sub is_super { 73 return 1 74 if $Vend::Cfg->{RemoteUser} 75 and $Vend::Cfg->{RemoteUser} eq $CGI::remote_user; 76 return 0 if ! $Vend::Session->{logged_in}; 77 return 0 if ! $Vend::username; 78 return 0 if $Vend::Cfg->{AdminUserDB} and ! $Vend::admin; 79 my $db = Vend::Data::database_exists_ref( 80 $Vend::Cfg->{Variable}{UI_ACCESS_TABLE} || 'access' 81 ); 82 return 0 if ! $db; 83 $db = $db->ref(); 84 my $result = $db->field($Vend::username, 'super'); 85 return $result; 86} 87 88sub is_logged { 89 return 1 90 if $Vend::Cfg->{RemoteUser} 91 and $Vend::Cfg->{RemoteUser} eq $CGI::remote_user; 92 return 0 if ! $Vend::Session->{logged_in}; 93 return 0 unless $Vend::admin or ! $Vend::Cfg->{AdminUserDB}; 94 return 1; 95} 96 97my %wrap_dest; 98my $compdb; 99 100sub ui_acl_enabled { 101 my $try = shift; 102 my $table; 103 $Global::SuperUserFunction = \&is_super; 104 my $default = defined $Global::Variable->{UI_SECURITY_OVERRIDE} 105 ? $Global::Variable->{UI_SECURITY_OVERRIDE} 106 : 0; 107 if ($Vend::superuser) { 108 return $Vend::UI_entry = { super => 1 }; 109 } 110 $table = $::Variable->{UI_ACCESS_TABLE} || 'access'; 111 $Vend::WriteDatabase{$table} = 1; 112 my $db = Vend::Data::database_exists_ref($table); 113 return $default unless $db; 114 $db = $db->ref() unless $Vend::Interpolate::Db{$table}; 115 my $uid = $try || $Vend::username || $CGI::remote_user; 116 if(! $uid or ! $db->record_exists($uid) ) { 117 return 0; 118 } 119 my $ref = $db->row_hash($uid) 120 or die "Bad database record for $uid."; 121 if($ref->{table_control}) { 122 $ref->{table_control_ref} = $ui_safe->reval($ref->{table_control}); 123 ref $ref->{table_control_ref} or delete $ref->{table_control_ref}; 124 } 125 return $ref if $try; 126 $Vend::UI_entry = $ref; 127} 128 129sub get_ui_table_acl { 130 my ($table, $user, $keys) = @_; 131 $table = $::Values->{mv_data_table} unless $table; 132 my $acl_top; 133 if($user and $user ne $Vend::username) { 134 if ($Vend::UI_acl{$user}) { 135 $acl_top = $Vend::UI_acl{$user}; 136 } 137 else { 138 my $ui_table = $::Variable->{UI_ACCESS_TABLE} || 'access'; 139 my $acl_txt = Vend::Interpolate::tag_data($ui_table, 'table_control', $user); 140 return undef unless $acl_txt; 141 $acl_top = $ui_safe->reval($acl_txt); 142 return undef unless ref($acl_top); 143 } 144 $Vend::UI_acl{$user} = $acl_top; 145 return keys %$acl_top if $keys; 146 return $acl_top->{$table}; 147 } 148 else { 149 unless ($acl_top = $Vend::UI_entry) { 150 return undef unless ref($acl_top = ui_acl_enabled()); 151 } 152 } 153 return undef unless defined $acl_top->{table_control_ref}; 154 return $acl_top->{table_control_ref}{$table}; 155} 156 157sub ui_acl_grep { 158 my ($acl, $name, @entries) = @_; 159 my $val; 160 my %ok; 161 @ok{@entries} = @entries; 162 if($val = $acl->{owner_field} and $name eq 'keys') { 163 my $u = $Vend::username; 164 my $t = $acl->{table} 165 or do{ 166 ::logError("no table name with owner_field."); 167 return undef; 168 }; 169 for(@entries) { 170 171 my $v = ::tag_data($t, $val, $_); 172 $ok{$_} = $v eq $u; 173 } 174 } 175 else { 176 if($val = $acl->{"no_$name"}) { 177 for(@entries) { 178 $ok{$_} = ! ui_check_acl($_, $val); 179 } 180 } 181 if($val = $acl->{"yes_$name"}) { 182 for(@entries) { 183 $ok{$_} &&= ui_check_acl($_, $val); 184 } 185 } 186 } 187 return (grep $ok{$_}, @entries); 188} 189 190sub ui_acl_atom { 191 my ($acl, $name, $entry) = @_; 192 my $val; 193 my $status = 1; 194 if($val = $acl->{"no_$name"}) { 195 $status = ! ui_check_acl($entry, $val); 196 } 197 if($val = $acl->{"yes_$name"}) { 198 $status &&= ui_check_acl($entry, $val); 199 } 200 return $status; 201} 202 203sub ui_extended_acl { 204 my ($item, $string) = @_; 205 $string = " $string "; 206 my ($name, $sub) = split /=/, $item, 2; 207 return 0 if $string =~ /[\s,]!$name(?:[,\s])/; 208 return 1 if $string =~ /[\s,]$name(?:[,\s])/; 209 my (@subs) = split //, $sub; 210 for(@subs) { 211 return 0 if $string =~ /[\s,]!$name=[^,\s]*$sub/; 212 return 0 unless $string =~ /[\s,]$name=[^,\s]*$sub/; 213 } 214 return 1; 215} 216 217sub ui_check_acl { 218 my ($item, $string) = @_; 219 return ui_extended_acl(@_) if $item =~ /=/; 220 $string = " $string "; 221 return 0 if $string =~ /[\s,]!$item[=,\s]/; 222 return 1 if $string =~ /[\s,]$item[=,\s]/; 223 return ''; 224} 225 226sub ui_acl_global { 227 my $record = ui_acl_enabled(); 228 # First we see if we have ACL enforcement enabled 229 # If you don't, then people can do anything! 230 unless (ref $record) { 231 $::Scratch->{mv_data_enable} = $record; 232 return; 233 } 234 my $enable = delete $::Scratch->{mv_data_enable} || 1; 235 my $CGI = \%CGI::values; 236 my $Tag = new Vend::Tags; 237 $CGI->{mv_todo} = $CGI->{mv_doit} 238 if ! $CGI->{mv_todo}; 239 if( $Tag->if_mm('super')) { 240 $::Scratch->{mv_data_enable} = $enable; 241 return; 242 } 243 244 if( $CGI->{mv_todo} eq 'set' ) { 245 undef $::Scratch->{mv_data_enable}; 246 my $mml_enable = $Tag->if_mm('functions', 'mml'); 247 my $html_enable = ! $Tag->if_mm('functions', 'no_html'); 248 my $target = $CGI->{mv_data_table}; 249 $Vend::WriteDatabase{$target} = 1; 250 my $db = Vend::Data::database_exists_ref($target); 251 if(! $db) { 252 $::Scratch->{ui_failure} = "Table $target doesn't exist"; 253 return; 254 } 255 256 my $keyname = $CGI->{mv_data_key}; 257 if ($CGI->{mv_auto_export} 258 and $Tag->if_mm('!tables', undef, { table => "$target=x" }, 1) ) { 259 $::Scratch->{ui_failure} = "Unauthorized to export table $target"; 260 $CGI->{mv_todo} = 'return'; 261 return; 262 } 263 if ($Tag->if_mm('!tables', undef, { table => "$target=e" }, 1) ) { 264 $::Scratch->{ui_failure} = "Unauthorized to edit table $target"; 265 $CGI->{mv_todo} = 'return'; 266 return; 267 } 268 269 my @codes = grep /\S/, split /\0/, $CGI->{$keyname}; 270 for(@codes) { 271 unless( $db->record_exists($_) ) { 272 next if $Tag->if_mm('tables', undef, { table => "$target=c" }, 1); 273 $::Scratch->{ui_failure} = "Unauthorized to insert to table $target"; 274 $CGI->{mv_todo} = 'return'; 275 return; 276 } 277 next if $Tag->if_mm('keys', $_, { table => $target }, 1); 278 $CGI->{mv_todo} = 'return'; 279 $::Scratch->{ui_failure} = errmsg("Unauthorized for key %s", $_); 280 return; 281 } 282 283 my @fields = grep /\S/, split /[,\s\0]+/, $CGI->{mv_data_fields}; 284 push @fields, $CGI->{mv_blob_field} 285 if $CGI->{mv_blob_field}; 286 287 for(@fields) { 288 $CGI->{$_} =~ s/\[/[/g unless $mml_enable; 289 $CGI->{$_} =~ s/\</</g unless $html_enable; 290 next if $Tag->if_mm('columns', $_, { table => $target }, 1); 291 $CGI->{mv_todo} = 'return'; 292 $::Scratch->{ui_failure} = errmsg("Unauthorized for key %s", $_); 293 return; 294 } 295 296 $::Scratch->{mv_data_enable} = $enable; 297 } 298 elsif ($CGI->{mv_todo} eq 'deliver') { 299 if($Tag->if_mm('files', $CGI->{mv_data_file}, {}, 1 ) ) { 300 $::Scratch->{mv_deliver} = $CGI->{mv_data_file}; 301 } 302 else { 303 $::Scratch->{ui_failure} = errmsg( 304 "Unauthorized for file %s", 305 $CGI->{mv_data_file}, 306 ); 307 } 308 } 309 return; 310 311} 312 313sub list_keys { 314 my $table = shift; 315 my $opt = shift; 316 $table = $::Values->{mv_data_table} 317 unless $table; 318 my @keys; 319 my $record; 320 if(! ($record = $Vend::UI_entry) ) { 321 $record = ui_acl_enabled(); 322 } 323 324 my $acl; 325 my $keys; 326 if($record) { 327 $acl = get_ui_table_acl($table); 328 if($acl and $acl->{yes_keys}) { 329 @keys = grep /\S/, split /\s+/, $acl->{yes_keys}; 330 } 331 } 332 unless (@keys) { 333 my $db = Vend::Data::database_exists_ref($table); 334 return '' unless $db; 335 $db = $db->ref() unless $Vend::Interpolate::Db{$table}; 336 my $keyname = $db->config('KEY'); 337 if($db->config('LARGE')) { 338 return ::errmsg('--not listed, too large--'); 339 } 340 my $query = "select $keyname from $table order by $keyname"; 341 $keys = $db->query( 342 { 343 query => $query, 344 ml => $::Variable->{UI_ACCESS_KEY_LIMIT} || 500, 345 st => 'db', 346 } 347 ); 348 if(defined $keys) { 349 @keys = map {$_->[0]} @$keys; 350 } 351 else { 352 my $k; 353 while (($k) = $db->each_record()) { 354 push(@keys, $k); 355 } 356 if( $db->numeric($db->config('KEY')) ) { 357 @keys = sort { $a <=> $b } @keys; 358 } 359 else { 360 @keys = sort @keys; 361 } 362 } 363 } 364 if($acl) { 365 @keys = UI::Primitive::ui_acl_grep( $acl, 'keys', @keys); 366 } 367 my $joiner = $opt->{joiner} || "\n"; 368 return join($joiner, @keys); 369} 370 371sub list_tables { 372 my $opt = shift; 373 my @dbs; 374 my $d = $Vend::Cfg->{Database}; 375 @dbs = sort keys %$d; 376 my @outdb; 377 my $record = ui_acl_enabled(); 378 undef $record 379 unless ref($record) 380 and $record->{yes_tables} || $record->{no_tables}; 381 382 for(@dbs) { 383 next if $::Values->{ui_tables_to_hide} =~ /\b$_\b/; 384 if($record) { 385 next if $record->{no_tables} 386 and ui_check_acl($_, $record->{no_tables}); 387 next if $record->{yes_tables} 388 and ! ui_check_acl($_, $record->{yes_tables}); 389 } 390 push @outdb, $_; 391 } 392 393 @dbs = $opt->{nohide} ? (@dbs) : (@outdb); 394 $opt->{joiner} = " " if ! $opt->{joiner}; 395 396 my $string = join $opt->{joiner}, grep /\S/, @dbs; 397 if(defined $::Values->{mv_data_table}) { 398 return $string unless $d->{$::Values->{mv_data_table}}; 399 my $size = -s $Vend::Cfg->{ProductDir} . 400 "/" . $d->{$::Values->{mv_data_table}}{'file'}; 401 $size = 3_000_000 if $size < 1; 402 $::Values->{ui_too_large} = $size > 100_000 ? 1 : ''; 403 $::Values->{ui_way_too_large} = $size > 2_000_000 ? 1 : ''; 404 local($_) = $::Values->{mv_data_table}; 405 $::Values->{ui_rotate_spread} = $::Values->{ui_tables_to_rotate} =~ /\b$_\b/; 406 } 407 return $string; 408} 409 410sub list_images { 411 my ($base, $suf) = @_; 412 return undef unless -d $base; 413#::logDebug("passed suf=$suf"); 414 $suf = '\.(GIF|gif|JPG|JPEG|jpg|jpeg|png|PNG)' 415 unless $suf; 416 my @names; 417 my $regex; 418 eval { 419 $regex = qr{$suf$}; 420 }; 421 return undef if $@; 422 my $wanted = sub { 423 return undef unless -f $_; 424 return undef unless $_ =~ $regex; 425 my $n = $File::Find::name; 426 $n =~ s:^$base/?::; 427 push(@names, $n); 428 }; 429 find($wanted, $base . '/'); 430 return sort @names; 431} 432 433sub list_glob { 434 my($spec, $prefix) = @_; 435 my $globspec = $spec; 436 if($prefix) { 437 $globspec =~ s:^\s+::; 438 $globspec =~ s:\s+$::; 439 $globspec =~ s:^:$prefix:; 440 $globspec =~ s:\s+: $prefix:g; 441 } 442 my @files = glob($globspec); 443 if($prefix) { 444 @files = map { s:^$prefix::; $_ } @files; 445 } 446 return @files; 447} 448 449sub list_pages { 450 my ($keep, $suf, $base) = @_; 451 $suf = $Vend::Cfg->{HTMLsuffix} if ! $suf; 452 $base = Vend::Util::catfile($Vend::Cfg->{VendRoot}, $base) if $base; 453 $base ||= $Vend::Cfg->{PageDir}; 454 my @names; 455 $suf = quotemeta($suf); 456#::logDebug("Finding, ext=$suf base=$base"); 457 my $wanted = sub { 458 return undef unless -f $_; 459 return undef unless /$suf$/; 460 my $n = $File::Find::name; 461 $n =~ s:^$base/?::; 462 $n =~ s/$suf$// unless $keep; 463 push(@names, $n); 464 }; 465 find($wanted, $base); 466#::logDebug("Found files: " . join (",", @names)); 467 return sort @names; 468} 469 470my %Break = ( 471 'variable' => 1, 472 'subroutine' => 1, 473 474); 475 476my %Format_routine; 477 478sub rotate { 479 my($base, $options) = @_; 480 481 unless ($base) { 482 ::logError( errmsg("%s: called rotate without file.", caller() ) ); 483 return undef; 484 } 485 486 if(! $options) { 487 $options = {}; 488 } 489 elsif (! ref $options) { 490 $options = {Motion => 'unsave'}; 491 } 492 493 494 my $dir = '.'; 495 496 if( $options->{Directory} ) { 497 $dir = $options->{Directory}; 498 } 499 500 if ($base =~ s:(.*)/:: ) { 501 $dir .= "/$1"; 502 } 503 504 my $motion = $options->{Motion} || 'save'; 505 506 $options->{max} = 10 if ! defined $options->{max}; 507 508 $dir =~ s:/+$::; 509 510 if("\L$motion" eq 'save' and ! -f "$dir/$base+") { 511 File::Copy::copy("$dir/$base", "$dir/$base+") 512 or die "copy $dir/$base to $dir/$base+: $!\n"; 513 } 514 515 opendir(forwardDIR, $dir) || die "opendir $dir: $!\n"; 516 my @files; 517 @files = grep /^$base/, readdir forwardDIR; 518 my @forward; 519 my @backward; 520 my $add = '-'; 521 522 if("\L$motion" eq 'save') { 523 @backward = grep s:^($base\++):$dir/$1:, @files; 524 @forward = grep s:^($base-+):$dir/$1:, @files; 525 } 526 elsif("\L$motion" eq 'unsave') { 527 return 0 unless -f "$dir/$base-"; 528 @forward = grep s:^($base\++):$dir/$1:, @files; 529 @backward = grep s:^($base-+):$dir/$1:, @files; 530 $add = '+'; 531 } 532 else { 533 die "Bad motion: $motion"; 534 } 535 536 $base = "$dir/$base"; 537 538 539 my $base_exists = -f $base; 540 push @forward, $base if $base_exists; 541 542 if (@forward > $options->{max}) { 543 $#forward = $options->{max}; 544 } 545 546 for(reverse sort @forward) { 547 next unless -f $_; 548 rename $_, $_ . $add or die "rename $_ => $_+: $!\n"; 549 } 550 551 #return 1 unless $base_exists && @backward; 552 553 @backward = sort @backward; 554 555 unshift @backward, $base; 556 557 if (@backward > $options->{max}) { 558 $#backward = $options->{max}; 559 } 560 561 my $i; 562 for($i = 0; $i < $#backward; $i++) { 563 rename $backward[$i+1], $backward[$i] 564 or die "rename $backward[$i+1] => $backward[$i]: $!\n"; 565 } 566 567 if($options->{Touch}) { 568 my $now = time(); 569 utime $now, $now, $base; 570 } 571 return 1; 572} 573 5741; 575 576__END__ 577 578