[Top][All Lists]
[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[commit-womb] gnumaint fsd/gnufsd-psql gnufsd-psql
|
From: |
Kaloian Doganov |
|
Subject: |
[commit-womb] gnumaint fsd/gnufsd-psql gnufsd-psql |
|
Date: |
Mon, 20 Apr 2009 08:12:08 +0000 |
CVSROOT: /sources/womb
Module name: gnumaint
Changes by: Kaloian Doganov <kaloian> 09/04/20 08:12:08
Added files:
fsd : gnufsd-psql
Removed files:
. : gnufsd-psql
Log message:
Dumping script gnufsd-psql is moved to fsd/gnufsd-psql.
CVSWeb URLs:
http://cvs.savannah.gnu.org/viewcvs/gnumaint/gnufsd-psql?cvsroot=womb&r1=1.5&r2=0
http://cvs.savannah.gnu.org/viewcvs/gnumaint/fsd/gnufsd-psql?cvsroot=womb&rev=1.1
Patches:
Index: fsd/gnufsd-psql
===================================================================
RCS file: fsd/gnufsd-psql
diff -N fsd/gnufsd-psql
--- /dev/null 1 Jan 1970 00:00:00 -0000
+++ fsd/gnufsd-psql 20 Apr 2009 08:12:08 -0000 1.1
@@ -0,0 +1,359 @@
+#!/usr/bin/env perl
+# $Id: gnufsd-psql,v 1.1 2009/04/20 08:12:08 kaloian Exp $
+# Extract information about GNU packages from the Free Software
+# Directory's PostgreSQL database.
+#
+# Dependencies:
+# perl (5.8.x), libdbd-pg-perl, libdate-calc-perl, libipc-run-perl
+
+use warnings;
+use strict;
+use DBI;
+use Date::Calc qw ( check_date Delta_Days Add_Delta_YMD Today );
+use IPC::Run qw( run timeout );
+
+# Configuration:
+# ==============================
+# Database connection settings:
+my $dbname = "quagga";
+my $username = "django";
+my $password = "";
+
+# `activity-status' calculation:
+my @activity_interval = (-1, 0, 0); # One year ago (Y, M, D)
+my @activity_reference = Today ();
+#===============================
+
+my @activity_threshold = Add_Delta_YMD (@activity_reference,
+ @activity_interval);
+
+# FIXME: What about handling UTF-8 from PostgreSQL?
+
+my ($dbh, $sth_homepage, $sth_download_url, $sth_activity_status,
+ $sth_categories, $sth_category);
+
+my %user_level_enum = (
+ 0 => "unknown",
+ 1 => "beginner",
+ 2 => "intermediate",
+ 3 => "advanced");
+
+exit (&main ());
+
+# Connect to the database and prepare all reusable statements in
+# advance.
+sub db_connect ()
+{
+ $dbh = DBI->connect ("dbi:Pg:dbname=$dbname",
+ $username,
+ $password,
+ {AutoCommit => 0,
+ PrintError => 1,
+ RaiseError => 1});
+
+ $dbh->do ("SET datestyle TO ISO;"); # YYYY-MM-DD
+
+ $sth_homepage = $dbh->prepare (
+ "SELECT link FROM directory_projectwebresource
+ WHERE audience = 5 AND kind = 5 AND project_id = ?;");
+
+ $sth_download_url = $dbh->prepare (
+ "SELECT link FROM directory_projectwebresource
+ WHERE kind = 11 AND project_id = ? ORDER BY audience DESC;");
+
+ $sth_activity_status = $dbh->prepare (
+ "SELECT name, date FROM directory_version
+ WHERE project_id = ? ORDER BY date DESC;");
+
+ $sth_categories = $dbh->prepare (
+ "SELECT category_id FROM directory_project_categories
+ WHERE project_id = ?;");
+
+ $sth_category = $dbh->prepare (
+ "SELECT name, slug, parent_category_id FROM directory_category
+ WHERE id = ?;");
+}
+
+# Disconnect from the database.
+sub db_disconnect ()
+{
+ $dbh->disconnect ();
+}
+
+# Trim the useless whitespace that sometimes surrounds the values in
+# the database.
+# FIXME: What about collapsing internal whitespace?
+sub trim_whitespace
+{
+ my ($input) = @_;
+ return $input if ! defined $input;
+
+ my $type = ref ($input);
+ if ($type eq "SCALAR") {
+ return $input if ! defined $$input;
+ $$input =~ s/^\s+//; # leading whitespace
+ $$input =~ s/\s+$//; # trailing whitespace
+ $$input =~ s/\r//g; # delete all carriage returns
+ }
+ elsif ($type eq "HASH") {
+ trim_whitespace (\$_) foreach (values %$input);
+ }
+ elsif ($type eq "ARRAY") {
+ for my $row (@$input) {
+ trim_whitespace (\$_) foreach (values %$row);
+ }
+ }
+ else {
+ die "Don't know how to trim input '$input' of type '$type'!";
+ }
+ return $input;
+}
+
+# Fetch all rows resulted from a SELECT statement.
+sub all($)
+{
+ my ($sql) = @_;
+ return trim_whitespace ($dbh->selectall_arrayref ($sql, {Slice=>{}}));
+}
+
+# Fetch one row resulted from a SELECT statement.
+sub row($)
+{
+ my ($sql) = @_;
+ return trim_whitespace ($dbh->selectrow_hashref ($sql));
+}
+
+# Fetch one COLUMN from the first row resulted from a SELECT
+# statement.
+sub col($$)
+{
+ my ($sql, $col) = @_;
+ my $value = row ($sql);
+ return $value->{$col} if $value;
+}
+
+# Fetch all GNU projects.
+sub projects()
+{
+ return all ("SELECT id, name, slug, user_level, short_description,
+ full_description, entry_compiled_by, updated,
+ checkout_command
+ FROM directory_project
+ WHERE gnu IS TRUE ORDER BY slug;");
+}
+
+# Return mundane-name for a project. Returns an empty string if the
+# `mundane-name' field should be ommited for this project.
+sub mundane_name(\%)
+{
+ my ($project) = @_;
+ my $slug = $project->{"slug"};
+ my $name = $project->{"name"};
+
+ # Omit mundane-name if it is trivial, e.g. match the package name.
+ return "" if ($name eq $slug) or ($name eq ucfirst $slug);
+
+ # The mundane-name is non-trivial, return it.
+ return $name;
+}
+
+# Fetch homepage (if any) for a project. Returns an empty string if
+# the `homepage' field should be omitted for this project.
+sub homepage(\%)
+{
+ my ($project) = @_;
+ my $id = $project->{"id"};
+ my $slug = $project->{"slug"};
+ $sth_homepage->bind_param (1, $id);
+ my $url = col ($sth_homepage, "link");
+
+ # Mark explicitly the lack of homepage.
+ return "none" if ! $url;
+
+ # Do magic to suppress a homepage comforming to
+ # http://www.gnu.org/software/PACKAGE format.
+ return "" if $url =~
m#^http://www.gnu.org/software/$slug(/($slug.html)?)?$#i;
+
+ # This is non-trivial URL, return it as is.
+ return $url;
+}
+
+# Fetch download-url (if any) for a project. Returns an empty string
+# if the `download-url' field should be omitted for this project.
+sub download_url(\%)
+{
+ my ($project) = @_;
+ my $id = $project->{"id"};
+ my $slug = $project->{"slug"};
+ $sth_download_url->bind_param (1, $id);
+ my $url = col ($sth_download_url, "link");
+
+ # Mark explicitly the lack of download-url.
+ return "none" if ! $url;
+
+ # Do magic to supress a download-url comforming to
+ # ftp://ftp.gnu.org/gnu/PACKAGE format.
+ return "" if $url =~ m#^ftp://ftp.gnu.org/gnu/$slug/?$#i;
+
+ return $url;
+}
+
+# Converts SQL ISO date format (YYYY-MM-DD) to Date::Calc YMD.
+sub iso_date_to_ymd($)
+{
+ my ($iso_date) = @_;
+ my ($year, $month, $day) = split (/-/, $iso_date);
+ my @ymd = ($year, $month, $day);
+ return @ymd;
+}
+
+# Converts Date::Calc YMD to string.
+sub iso_date_to_str($) {
+ my ($date) = @_;
+ $date =~ s/-//g;
+ return $date;
+}
+
+# Fetch activity-status for a project.
+sub activity_status(\%)
+{
+ my ($project) = @_;
+ my $id = $project->{"id"};
+ $sth_activity_status->bind_param (1, $id);
+ my $row = row ($sth_activity_status);
+
+ return "stale" if ! $row;
+
+ my $status = "stale";
+ my $comments = "";
+ if ($row->{"date"}) {
+ my @release = iso_date_to_ymd ($row->{"date"});
+ if (check_date (@release)) {
+ $status = "ok" if Delta_Days (@activity_threshold, @release) >= 0;
+ }
+ else {
+ $comments .= " Invalid release date: $row->{date}.";
+ }
+ }
+
+ my $date = $row->{"date"};
+ $date =~ tr/-//d if $date;
+ $date = "" if ! $date;
+
+ my $number = $row->{"name"};
+ if ($number and not ($number eq "NO_VERSION_DATA")) {
+ $number = " ($number)";
+ }
+ else {
+ $number = "";
+ }
+
+ my $result = "$status $date$number";
+ $result .= " #" . $comments if $comments;
+ return $result;
+}
+
+# Formats a category_id to be suitable for dumping.
+sub format_category($)
+{
+ my ($id) = @_;
+ my @name_chain;
+ my @slug_chain;
+ do {
+ $sth_category->bind_param (1, $id);
+ my $cat = row ($sth_category);
+ my $name = $cat->{"name"};
+ my $slug = $cat->{"slug"};
+ push (@name_chain, $name);
+ push (@slug_chain, $slug);
+ $id = $cat->{"parent_category_id"};
+ } until ($id == 1);
+ my $names = join ("/", reverse (@name_chain));
+ my $slugs = join ("/", reverse (@slug_chain));
+ return "/$names (/$slugs)"
+}
+
+# Fetch categories for a project.
+sub categories(\%)
+{
+ my ($project) = @_;
+ my $id = $project->{"id"};
+ $sth_categories->bind_param (1, $id);
+ my $categories = all ($sth_categories);
+
+ my @result;
+ foreach my $category (@{$categories}) {
+ my $category_id = $category->{"category_id"};
+ push (@result, format_category ($category_id));
+ }
+ return sort (@result);
+}
+
+# Formats long muliparagraph text to be suitable for dumping.
+sub format_full_descr($)
+{
+ my ($descr) = @_;
+ my @cmd = "fmt";
+ my $out;
+ my $err;
+ run address@hidden, \$descr, \$out, \$err, timeout (20) or die "fmt: $?";
+ $out =~ s/\n/\n /g; # add space after every newline
+ $out =~ s/\s+$//; # trim trailing whitespace
+ return " " . $out;
+}
+
+# Dump a project to STDOUT.
+sub project(\%)
+{
+ my ($project) = @_;
+ my $id = $project->{"id"};
+ my $slug = $project->{"slug"};
+ my $name = $project->{"name"};
+ print "package: $project->{slug}\n";
+
+ my $mundane_name = mundane_name (%$project);
+ print "mundane-name: $mundane_name\n" if $mundane_name;
+
+ my $homepage = homepage (%$project);
+ print "homepage: $homepage\n" if $homepage;
+
+ my $download_url = download_url (%$project);
+ print "download-url: $download_url\n" if $download_url;
+
+ my $checkout_cmd = $project->{"checkout_command"};
+ if (defined $checkout_cmd and ! ($checkout_cmd eq '')) {
+ print "checkout-command: $checkout_cmd\n";
+ }
+
+ my $activity_status = activity_status (%$project);
+ print "activity-status: $activity_status\n";
+
+ my $user_level = $user_level_enum{$project->{"user_level"}};
+ print "user-level: $user_level\n";
+
+ print "category: $_\n" foreach (categories (%$project));
+
+ print "entry-compiled-by: $project->{entry_compiled_by}\n";
+
+ my @updated = iso_date_to_str ($project->{"updated"});
+ print "updated: @updated\n";
+
+ my $full_descr = format_full_descr($project->{"full_description"});
+ print "description: $project->{short_description}\n";
+ print "$full_descr\n";
+
+ print "\n";
+}
+
+# Main entry point.
+sub main
+{
+ db_connect ();
+ my $projects = projects ();
+ foreach my $project (@{$projects}) {
+ project (%$project);
+ }
+ print STDERR "DONE: " . @{$projects} . " projects exported.\n";
+ db_disconnect ();
+ return 0;
+}
Index: gnufsd-psql
===================================================================
RCS file: gnufsd-psql
diff -N gnufsd-psql
--- gnufsd-psql 20 Apr 2009 07:32:58 -0000 1.5
+++ /dev/null 1 Jan 1970 00:00:00 -0000
@@ -1,359 +0,0 @@
-#!/usr/bin/env perl
-# $Id: gnufsd-psql,v 1.5 2009/04/20 07:32:58 kaloian Exp $
-# Extract information about GNU packages from the Free Software
-# Directory's PostgreSQL database.
-#
-# Dependencies:
-# perl (5.8.x), libdbd-pg-perl, libdate-calc-perl, libipc-run-perl
-
-use warnings;
-use strict;
-use DBI;
-use Date::Calc qw ( check_date Delta_Days Add_Delta_YMD Today );
-use IPC::Run qw( run timeout );
-
-# Configuration:
-# ==============================
-# Database connection settings:
-my $dbname = "quagga";
-my $username = "django";
-my $password = "";
-
-# `activity-status' calculation:
-my @activity_interval = (-1, 0, 0); # One year ago (Y, M, D)
-my @activity_reference = Today ();
-#===============================
-
-my @activity_threshold = Add_Delta_YMD (@activity_reference,
- @activity_interval);
-
-# FIXME: What about handling UTF-8 from PostgreSQL?
-
-my ($dbh, $sth_homepage, $sth_download_url, $sth_activity_status,
- $sth_categories, $sth_category);
-
-my %user_level_enum = (
- 0 => "unknown",
- 1 => "beginner",
- 2 => "intermediate",
- 3 => "advanced");
-
-exit (&main ());
-
-# Connect to the database and prepare all reusable statements in
-# advance.
-sub db_connect ()
-{
- $dbh = DBI->connect ("dbi:Pg:dbname=$dbname",
- $username,
- $password,
- {AutoCommit => 0,
- PrintError => 1,
- RaiseError => 1});
-
- $dbh->do ("SET datestyle TO ISO;"); # YYYY-MM-DD
-
- $sth_homepage = $dbh->prepare (
- "SELECT link FROM directory_projectwebresource
- WHERE audience = 5 AND kind = 5 AND project_id = ?;");
-
- $sth_download_url = $dbh->prepare (
- "SELECT link FROM directory_projectwebresource
- WHERE kind = 11 AND project_id = ? ORDER BY audience DESC;");
-
- $sth_activity_status = $dbh->prepare (
- "SELECT name, date FROM directory_version
- WHERE project_id = ? ORDER BY date DESC;");
-
- $sth_categories = $dbh->prepare (
- "SELECT category_id FROM directory_project_categories
- WHERE project_id = ?;");
-
- $sth_category = $dbh->prepare (
- "SELECT name, slug, parent_category_id FROM directory_category
- WHERE id = ?;");
-}
-
-# Disconnect from the database.
-sub db_disconnect ()
-{
- $dbh->disconnect ();
-}
-
-# Trim the useless whitespace that sometimes surrounds the values in
-# the database.
-# FIXME: What about collapsing internal whitespace?
-sub trim_whitespace
-{
- my ($input) = @_;
- return $input if ! defined $input;
-
- my $type = ref ($input);
- if ($type eq "SCALAR") {
- return $input if ! defined $$input;
- $$input =~ s/^\s+//; # leading whitespace
- $$input =~ s/\s+$//; # trailing whitespace
- $$input =~ s/\r//g; # delete all carriage returns
- }
- elsif ($type eq "HASH") {
- trim_whitespace (\$_) foreach (values %$input);
- }
- elsif ($type eq "ARRAY") {
- for my $row (@$input) {
- trim_whitespace (\$_) foreach (values %$row);
- }
- }
- else {
- die "Don't know how to trim input '$input' of type '$type'!";
- }
- return $input;
-}
-
-# Fetch all rows resulted from a SELECT statement.
-sub all($)
-{
- my ($sql) = @_;
- return trim_whitespace ($dbh->selectall_arrayref ($sql, {Slice=>{}}));
-}
-
-# Fetch one row resulted from a SELECT statement.
-sub row($)
-{
- my ($sql) = @_;
- return trim_whitespace ($dbh->selectrow_hashref ($sql));
-}
-
-# Fetch one COLUMN from the first row resulted from a SELECT
-# statement.
-sub col($$)
-{
- my ($sql, $col) = @_;
- my $value = row ($sql);
- return $value->{$col} if $value;
-}
-
-# Fetch all GNU projects.
-sub projects()
-{
- return all ("SELECT id, name, slug, user_level, short_description,
- full_description, entry_compiled_by, updated,
- checkout_command
- FROM directory_project
- WHERE gnu IS TRUE ORDER BY slug;");
-}
-
-# Return mundane-name for a project. Returns an empty string if the
-# `mundane-name' field should be ommited for this project.
-sub mundane_name(\%)
-{
- my ($project) = @_;
- my $slug = $project->{"slug"};
- my $name = $project->{"name"};
-
- # Omit mundane-name if it is trivial, e.g. match the package name.
- return "" if ($name eq $slug) or ($name eq ucfirst $slug);
-
- # The mundane-name is non-trivial, return it.
- return $name;
-}
-
-# Fetch homepage (if any) for a project. Returns an empty string if
-# the `homepage' field should be omitted for this project.
-sub homepage(\%)
-{
- my ($project) = @_;
- my $id = $project->{"id"};
- my $slug = $project->{"slug"};
- $sth_homepage->bind_param (1, $id);
- my $url = col ($sth_homepage, "link");
-
- # Mark explicitly the lack of homepage.
- return "none" if ! $url;
-
- # Do magic to suppress a homepage comforming to
- # http://www.gnu.org/software/PACKAGE format.
- return "" if $url =~
m#^http://www.gnu.org/software/$slug(/($slug.html)?)?$#i;
-
- # This is non-trivial URL, return it as is.
- return $url;
-}
-
-# Fetch download-url (if any) for a project. Returns an empty string
-# if the `download-url' field should be omitted for this project.
-sub download_url(\%)
-{
- my ($project) = @_;
- my $id = $project->{"id"};
- my $slug = $project->{"slug"};
- $sth_download_url->bind_param (1, $id);
- my $url = col ($sth_download_url, "link");
-
- # Mark explicitly the lack of download-url.
- return "none" if ! $url;
-
- # Do magic to supress a download-url comforming to
- # ftp://ftp.gnu.org/gnu/PACKAGE format.
- return "" if $url =~ m#^ftp://ftp.gnu.org/gnu/$slug/?$#i;
-
- return $url;
-}
-
-# Converts SQL ISO date format (YYYY-MM-DD) to Date::Calc YMD.
-sub iso_date_to_ymd($)
-{
- my ($iso_date) = @_;
- my ($year, $month, $day) = split (/-/, $iso_date);
- my @ymd = ($year, $month, $day);
- return @ymd;
-}
-
-# Converts Date::Calc YMD to string.
-sub iso_date_to_str($) {
- my ($date) = @_;
- $date =~ s/-//g;
- return $date;
-}
-
-# Fetch activity-status for a project.
-sub activity_status(\%)
-{
- my ($project) = @_;
- my $id = $project->{"id"};
- $sth_activity_status->bind_param (1, $id);
- my $row = row ($sth_activity_status);
-
- return "stale" if ! $row;
-
- my $status = "stale";
- my $comments = "";
- if ($row->{"date"}) {
- my @release = iso_date_to_ymd ($row->{"date"});
- if (check_date (@release)) {
- $status = "ok" if Delta_Days (@activity_threshold, @release) >= 0;
- }
- else {
- $comments .= " Invalid release date: $row->{date}.";
- }
- }
-
- my $date = $row->{"date"};
- $date =~ tr/-//d if $date;
- $date = "" if ! $date;
-
- my $number = $row->{"name"};
- if ($number and not ($number eq "NO_VERSION_DATA")) {
- $number = " ($number)";
- }
- else {
- $number = "";
- }
-
- my $result = "$status $date$number";
- $result .= " #" . $comments if $comments;
- return $result;
-}
-
-# Formats a category_id to be suitable for dumping.
-sub format_category($)
-{
- my ($id) = @_;
- my @name_chain;
- my @slug_chain;
- do {
- $sth_category->bind_param (1, $id);
- my $cat = row ($sth_category);
- my $name = $cat->{"name"};
- my $slug = $cat->{"slug"};
- push (@name_chain, $name);
- push (@slug_chain, $slug);
- $id = $cat->{"parent_category_id"};
- } until ($id == 1);
- my $names = join ("/", reverse (@name_chain));
- my $slugs = join ("/", reverse (@slug_chain));
- return "/$names (/$slugs)"
-}
-
-# Fetch categories for a project.
-sub categories(\%)
-{
- my ($project) = @_;
- my $id = $project->{"id"};
- $sth_categories->bind_param (1, $id);
- my $categories = all ($sth_categories);
-
- my @result;
- foreach my $category (@{$categories}) {
- my $category_id = $category->{"category_id"};
- push (@result, format_category ($category_id));
- }
- return sort (@result);
-}
-
-# Formats long muliparagraph text to be suitable for dumping.
-sub format_full_descr($)
-{
- my ($descr) = @_;
- my @cmd = "fmt";
- my $out;
- my $err;
- run address@hidden, \$descr, \$out, \$err, timeout (20) or die "fmt: $?";
- $out =~ s/\n/\n /g; # add space after every newline
- $out =~ s/\s+$//; # trim trailing whitespace
- return " " . $out;
-}
-
-# Dump a project to STDOUT.
-sub project(\%)
-{
- my ($project) = @_;
- my $id = $project->{"id"};
- my $slug = $project->{"slug"};
- my $name = $project->{"name"};
- print "package: $project->{slug}\n";
-
- my $mundane_name = mundane_name (%$project);
- print "mundane-name: $mundane_name\n" if $mundane_name;
-
- my $homepage = homepage (%$project);
- print "homepage: $homepage\n" if $homepage;
-
- my $download_url = download_url (%$project);
- print "download-url: $download_url\n" if $download_url;
-
- my $checkout_cmd = $project->{"checkout_command"};
- if (defined $checkout_cmd and ! ($checkout_cmd eq '')) {
- print "checkout-command: $checkout_cmd\n";
- }
-
- my $activity_status = activity_status (%$project);
- print "activity-status: $activity_status\n";
-
- my $user_level = $user_level_enum{$project->{"user_level"}};
- print "user-level: $user_level\n";
-
- print "category: $_\n" foreach (categories (%$project));
-
- print "entry-compiled-by: $project->{entry_compiled_by}\n";
-
- my @updated = iso_date_to_str ($project->{"updated"});
- print "updated: @updated\n";
-
- my $full_descr = format_full_descr($project->{"full_description"});
- print "description: $project->{short_description}\n";
- print "$full_descr\n";
-
- print "\n";
-}
-
-# Main entry point.
-sub main
-{
- db_connect ();
- my $projects = projects ();
- foreach my $project (@{$projects}) {
- project (%$project);
- }
- print STDERR "DONE: " . @{$projects} . " projects exported.\n";
- db_disconnect ();
- return 0;
-}
| [Prev in Thread] |
Current Thread |
[Next in Thread] |
- [commit-womb] gnumaint fsd/gnufsd-psql gnufsd-psql,
Kaloian Doganov <=