dist/lib/UI/Primitive.pm

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