File: core.pl

package info (click to toggle)
pdbv 2.0.10.1
  • links: PTS
  • area: main
  • in suites: sarge
  • size: 436 kB
  • ctags: 52
  • sloc: perl: 1,004; sh: 291; makefile: 129
file content (286 lines) | stat: -rwxr-xr-x 10,038 bytes parent folder | download | duplicates (3)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
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
65
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
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
# (c) 2002-2005 Mathieu Roy <yeupou@gnu.org>
# core.pl: this file is part of package_db_view
#
# This program is free software; you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation; either version 2 of the License, or
# (at your option) any later version.
# You should have received a copy of the GNU General Public License
# along with this program; if not, write to the Free Software
# Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
#
#  take a look at http://gna.org/projects/pdbv
#  send comments at <pdbv-dev@gna.org>
#
#  $Id: core.pl,v 1.39 2005/02/23 10:42:20 yeupou Exp $

print "The purpose of this file is not being executed alone";
exit;

#### Core Functions ####

sub PdbvSHelp {
    print gettext("Usage: pdbv [OPTIONS]")."\n\n";
    print gettext("  -h, --help                 display this help and exit")."\n";
    print gettext("      --version              output version information and exit")."\n\n";
    print gettext("  -d, --dir=/path            output directory")."\n";
    print gettext("  -l, --listing=[all|basic]  listing type generated (default is all)")."\n";
    print 
    print gettext("      --light                run faster but generate less polished output")."\n";
    print gettext("                             (will set listing to basic)")."\n\n";
    print gettext("  -f, --force                refresh the whole output without tests")."\n";
    print gettext("      --xhtml                xhtml output (default)")."\n";
    if ($pdbv_type eq 'pdbv') {
	print gettext("      --dpkg-dir=/path       alternative dpkg top directory")."\n";
	print sprintf(gettext("                             (currently: %s)"), $dpkg_dir)."\n";
	print gettext("      --popcon-file=/path    alternative popularity contest file")."\n";
	print sprintf(gettext("                             (currently: %s)"), $popcon_file)."\n";
    }
    print gettext("Report bugs or suggestions to ")."<$smail>.\n";
}


sub PdbvSVersion {
    print gettext("$sname - $sver")."\n\n";
    print gettext("Copyright (c) $sauthor <$smail>")."\n";
    print gettext("See AUTHORS for more details.")."\n\n";
    print gettext("This is free software; see the source for copying conditions.  There is NO warranty; not even for MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.")."\n";
}

sub PdbvReadConf {
    if (-e $_[0]) {
	defined do $_[0] or warn "Unable to run ".$_[0], RED,"Most commonly, it's a privilege issue.",RESET,"\nAsked";
    }
}

sub PdbvExecutionTime {
    # $epoch_start should have been set since the start.
    # Return diff between $epoch_start and $epoch_now.
    #
    # If arg = raw, we return the epoch diff value.
    # If not, we return something human readable.
    my $diff = time - $epoch_start;

    print "Execution time $diff\n" if $debug;
    
    if ($_[0] eq 'raw') {
	return $diff
    } else {     

	my $sec = $diff % 60;
	$diff = ($diff - $sec) / 60;
	my $min = $diff % 60;
	$diff = ($diff - $min) / 60;
	my $hour = $diff % 24;
	$diff = ($diff - $hour) / 24;
	my $day = $diff % 7;
	
	if ($day > 0) {
	    return sprintf(gettext("%s days, %s hours, %s minutes and %s seconds"), $day, $hour, $min, $sec);
	} elsif ($hour > 0) {
	    return sprintf(gettext("%s hours, %s minutes and %s seconds"), $hour, $min, $sec);
	} else {
	    return sprintf(gettext("%s minutes and %s seconds"), $min, $sec);
	}

    }
}

sub PdbvGenerate {
    # Init 
    mkdir $working_dir."/package";
    
    # Gen each package frame:
    #
    #  * we touch files or create it in case it does not already exists
    #  * we don't create an item if it already exists
    #  * we remove files that havent been touched before the test item:
    #    no longer in the database
    
    PdbvPackageInit();
    PdbvXhtmlInit();


    #  test every package and generate, if needed, 
    #  feed the hash of known files (not orphans)
    my %notorphans;
    foreach my $thispack (PdbvPackages()) {
	my $thispackout = $working_dir."/package/".$thispack."_".$package_version{$thispack}.$output_ext;
	if (! -e $thispackout || $force) {
	    open(ITEM, "> $thispackout");
	    PdbvXhtmlPrintItemFrame(ITEM, $thispack);
	    close(ITEM);
	    $does_new_package_exist = "1";
	    print "$thispackout written\n" if $debug;

	} else {
	    print "$thispackout already existing\n" if $debug;
	}
	$notorphans{$thispackout} = 1;
	
    }
   
    #  seek and destroy orphans
    my @orphans;
    opendir(OUTDIR, $working_dir."/package/");
    while (defined(my $file = readdir(OUTDIR))) {
	# take care only of html files
	next unless $file =~ m/.*\.html$/;
	# add in the orphan list any file that is not in known file hash
	push(@orphans, $working_dir."/package/".$file) unless $notorphans{$working_dir."/package/".$file}

    }
    
    if ($debug) {
	print "orphans:\n";
	foreach my $orphan (@orphans) {
	    print " - ".$orphan."\n";
	}
    }
	
    # Remove each orphans one by one
    my $orphans_removed = unlink @orphans;
    $does_orphan_exist = 1 if $orphans_removed > 1; 
    print "$orphans_removed orphans removed\n" if $debug;
    

    # Gen the lists frames:
    #  basic list is alway generated.
    if ($does_new_package_exist || $does_orphan_exist) {	
	open(LIST, "> ".$working_dir."/list".$output_ext);
	PdbvXhtmlPrintListFrame(LIST);
	close(LIST);
	print "LIST written\n" if $debug;

	if ($listing) {
	    open(LIST, "> ".$working_dir."/list_bygroup".$output_ext);
	    PdbvXhtmlPrintListFrame(LIST, "package_section");
	    close(LIST);
	    print "LIST by group written\n" if $debug;
	    
	    open(LIST, "> ".$working_dir."/list_bydate".$output_ext);
	    PdbvXhtmlPrintListFrame(LIST, "package_installdate");
	    close(LIST);
	    print "LIST by date written\n" if $debug;
	    
	    open(LIST, "> ".$working_dir."/list_byusage".$output_ext);
	    PdbvXhtmlPrintListFrame(LIST, "package_popularity");
	    close(LIST);
	    print "LIST by usage written\n" if $debug;
	    
	    # FIXME: Need to figure out to do that cleanly.
	    #open(LIST, "> ".$working_dir."/list_bysize".$output_ext);
	    #PdbvXhtmlPrintListFrame(LIST, "package_installedsize");
	    #close(LIST);
	    #print "LIST by size written\n" if $debug;
	}
    }
    # Gen the listing frame, which print the listing available:
    open(INDEX, "> ".$working_dir."/listing".$output_ext);
    PdbvXhtmlPrintListingFrame(INDEX);
    close(INDEX);
    print "INDEX written\n" if $debug;

    # Gen an index:
    open(INDEX, "> ".$working_dir."/index".$output_ext);
    PdbvXhtmlPrintIndexFrame(INDEX);
    close(INDEX);
    print "INDEX written\n" if $debug;

    # Gen a general info frame:
    # (lately because it prints execution time)
    open(INFO, "> ".$working_dir."/info".$output_ext);
    PdbvXhtmlPrintInfoFrame(INFO);
    print "INFO written\n" if $debug;
    close(INFO);

    # Add required files (.htaccess, etc...) 
    PdbvXhtmlAddRequiredFiles();
    
    # If we are root and working with the cron working_dir
    # (called output_dir), we chmod files to nobody, to avoid
    # breaking cronjobs.
    if ((getpwuid($<))[0] eq 'root' && $output_dir eq $working_dir) {
	# Until perl chown support -R option, we'll use GNU chown
	# (if there is an easy perl workaround, write to pdbv-dev)
	`chown nobody -R $output_dir > /dev/null`;
	print "$output_dir chowned to nobody\n" if $debug;
    }
}

#### Run baby run! ####
# Get options
# First, get options from the configuration file
PdbvReadConf($confdir."/pdbvrc");
PdbvReadConf($ENV{HOME}."/.pdbvrc");
PdbvReadConf($ENV{HOME}."/.pdbvrc2");

# In configure file, with use OUTPUT_dir to define WORKING_dir
our $working_dir = $output_dir if $output_dir;

# Second, get options from the command line
# (override previous)
eval {
    $getopt = GetOptions("help" => \$arg_help,
			 "version" => \$arg_version,
			 "debug" => \$debug,
			 "force" => \$force,
			 "dir=s" => \$working_dir,
			 "listing=s" => \$listing,
			 "cron=s" => \$arg_cron,
			 "xhtml" => \$arg_xhtml,
			 "light" => \$light,
			 "dpkg-dir=s" => \$dpkg_dir,
			 "popcon-file=s" => \$popcon_file)
};

$listing = "0" if $listing eq 'basic' || $light;
$output = "xhtml" if $arg_xhtml;

# If debug mode, show full debug info
if ($debug) { use warnings; }

# User may be looking for infos
PdbvSHelp() && exit if $arg_help;
PdbvSVersion() && exit if $arg_version;

# If started by cron, we have to check if the user really asked the cronjob
if ($arg_cron) {
    exit unless $cron eq $arg_cron;
    setlocale(LC_ALL, $cron_lang) if $cron_lang;
}

# Third, check if every required options are set.
# Also ask to avoid running pdbv as root, if not started by cron. 
die gettext("You must choose an output directory.\nCheck your pdbvrc2 or add a command line's option.")."\n" unless $working_dir;
if ((getpwuid($<))[0] eq 'root' && ! $arg_cron) {
    # We use getpwuid() instead of getlogin() because when using `su` 
    # the result is oftenly erroneous with getlogin().
    print gettext("Running pdbv as root jeopardizes your system security, you should not do that.")."\n\n";
    print sprintf(gettext("If you are not running pdbv as root, please fill a bug report on our project page. Do not forget to tell us which perl version and operating system you are using. Give us also the result of %s"), "\`perl -e \"print \$<; print ((getpwuid(\$<))[0]);\"\`")."\n";
}

# If debug mode, show options
if ($debug) {
    print "DEBUG = $debug
FORCE = $force
OUTPUT = $output
WORKING_dir = $working_dir
LISTING = $listing\n";
}

# Finally, do the job

# First, check if we need to create an output dir. Do not 
# create the output dir with -p option. Assume that if base path
# for the output does not exists, it can be a wrong path.
mkdir $working_dir unless (-e $working_dir);
unless (-e $working_dir) {
    print gettext("Unable to create ").$working_dir."\n";
    print gettext("Check if the parent directory exists.")."\n";
    print gettext("Check also its mode and ownership.")."\n";
}
PdbvGenerate();


#### END ####