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/\[/&#91;/g unless $mml_enable;
289			$CGI->{$_} =~ s/\</&lt;/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