[commit-womb] gnumaint gnufsd-psql

[Kaloian Doganov]

CVSROOT:        /sources/womb
Module name:    gnumaint
Changes by:     Kaloian Doganov <kaloian>       09/02/24 09:56:46

Added files:
        .              : gnufsd-psql 

Log message:
        Initial import.

CVSWeb URLs:
http://cvs.savannah.gnu.org/viewcvs/gnumaint/gnufsd-psql?cvsroot=womb&rev=1.1

Patches:
Index: gnufsd-psql
===================================================================
RCS file: gnufsd-psql
diff -N gnufsd-psql
--- /dev/null   1 Jan 1970 00:00:00 -0000
+++ gnufsd-psql 24 Feb 2009 09:56:46 -0000      1.1
@@ -0,0 +1,257 @@
+#!/usr/bin/env perl
+# $Id: gnufsd-psql,v 1.1 2009/02/24 09:56:46 kaloian Exp $
+# Extract information about GNU packages from the Free Software
+# Directory's PostgreSQL database.
+#
+# Dependencies:
+#   perl (5.8.x), libdbd-pg-perl
+
+use warnings;
+use strict;
+use DBI;
+use Time::Local;
+
+# Configuration:
+# ==============================
+# Database connection settings:
+my $dbname = "quagga";
+my $username = "django";
+my $password = "";
+
+# `activity-status' calculation:
+my $activity_interval = 365 * 24 * 60 * 60; # ~ one year (in secs)
+my $activity_reference = time(); # now
+#===============================
+
+# FIXME: What about handling UTF-8 from PostgreSQL?
+
+# FIXME: Use Date::Calc instead of manual Unix time calculations
+#        (libdate-calc-perl is already installed on fencepost).
+
+my ($dbh, $sth_homepage, $sth_download_url, $sth_activity_status);
+
+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;");
+}
+
+# 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") {
+    $$input =~ s/^\s+//; # leading whitespace
+    $$input =~ s/\s+$//; # trailing whitespace
+  }
+  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, slug, name 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 Unix time.
+sub iso_date_to_unix($)
+{
+  my ($iso_date) = @_;
+  my ($year, $month, $day) = split (/-/, $iso_date);
+  $month--;
+  $year -= 1900;
+  my $unix = timegm (0, 0, 0, $day, $month, $year);
+}
+
+# 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";
+  if ($row->{"date"}) {        
+    my $release = iso_date_to_unix ($row->{"date"});
+    my $now = gmtime ();
+    my $threshold = $activity_reference - $activity_interval;
+    $status = "ok" if $release > $threshold;
+  }
+
+  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 = "";
+  }
+
+  return "$status $date$number";
+}
+
+# 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 $activity_status = activity_status (%$project);
+  print "activity-status: $activity_status\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;
+}