use Perl

Since use.perl.org has become my de facto backup solution, I now post the scripts I use to blog from winders. These are modified versions of the scripts I mentioned in a use.perl.org article published a while ago.

The emacs file:

(defvar prog
   "C:/perl/bin/perl.exe F:/blog/use_perl_blog.pl"
   "use_perl_journal: A SOAP client for use.perl journaling"
)

(defun edit-entry ()
   "Add an entry or edit an existing one"
   (interactive)
   (setq cmd (concat prog " edit"))
   (widen)
   (shell-command-on-region (point-min) (point-max) cmd)
)

(defun get-entry (n)
  "Get journal entry from use.perl.org"
  (interactive "sJournal ID: ")
  (setq buffer (generate-new-buffer "*use_perl_journal*"))
  (switch-to-buffer buffer)
  (setq cmd (concat prog (concat " -i " (concat n " get"))))
  (shell-command-on-region (point-min) (point-max) cmd 1 nil nil)
)

(defun list-entries (uid limit)
   "Get journal entries"
   (interactive "sUser ID: \nsLimit: ")
   (setq buffer (generate-new-buffer "*use_perl:list_entries*"))
   (switch-to-buffer buffer)
   (setq cmd (concat prog (concat " -l " (concat limit " -i " (concat uid " list")))))
   (shell-command-on-region (point-min) (point-max) cmd 1 nil nil)
)

(defun delete-entry (jid)
  "Delete journal entry"
  (interactive "nEntry ID: ")
  (setq cmd (concat prog (concat " -i " (concat jid (concat " delete")))))
  (shell-command-on-region (point-min) (point-max) cmd 1 nil nil)
)

;; don't use tabs
(setq-default indent-tabs-mode nil)

(global-set-key "\C-xtl" `list-entries)
(global-set-key "\C-xtg" `get-entry)
(global-set-key "\C-xts" `edit-entry)
(global-set-key "\C-xtm" `edit-entry)
(global-set-key "\C-xtd" `delete-entry)

The perl script:

# -*-cperl-*-
# A SOAP client to post USE.PERL.ORG journal entries

use strict;
use HTTP::Cookies;
use SOAP::Lite;
use File::Basename;
use Digest::MD5 'md5_hex';
use Data::Dumper;
use Getopt::Std;

use constant DEBUG => 0;
use constant UID   => -1; # your UID here
use constant PW    => 's3cr3t'; # your pw here
use constant URI   => 'http://use.perl.org/Slash/Journal/SOAP';
use constant PROXY => 'http://use.perl.org/journal.pl';

my $Dispatch = {
                 'get'  => \&get_entry,
                 'list' => \&list_entries,
                 'add'  => \&add_entry,
                 'edit' => \&edit_entry,
                 'delete' => \&delete_entry,
               };

my $opts = {};
getopts('h?vi:u:l:', $opts);

my $action = pop @ARGV;

unless ($action) {
  print usage(), "\n";
  exit;
}

my $soap_client = make_soap();

my $exit_value = 0;
if (defined $Dispatch->{$action}) {
  $exit_value = !$Dispatch->{$action}->($opts, $soap_client);
} else {
  warn("Unknown action '$action'");
  print usage();
  $exit_value = 1;
}

exit $exit_value;

#------
# subs
#------

sub usage {
  my $base = basename($0);
  return qq[
$base - manage use.perl.org blog

USAGE:
   $base [options] [actions]

OPTIONS:
   ?       print this screen
   h       print this screen
   v       verbose mode
   i <id>  entry ID
   l <int> limit the number of listed entries to this number
   u <id>  use.perl.org user ID

ACTIONS:
  add
  delete
  edit
  get
  list
Input files take the following form:
      id:
      subject:
          body:
];
}

sub make_soap {
  my $cookie = HTTP::Cookies->new;
  $cookie->set_cookie( 0,
               user => bakeUserCookie(&UID, &PW),
               "/",
               "use.perl.org",
             );

  return SOAP::Lite->uri(URI)->proxy(PROXY, cookie_jar => $cookie);
}

sub add_entry {
  my ($opts, $c, $in) = @_;

  $in ||= parse_input();

  my $ret;
  if ($in->{subject} && $in->{body}) {
    if ($in->{id}) {
      return edit_entry(@_, $in);
    } else {
      $ret = $c->add_entry($in->{subject}, $in->{body});
    }
  } else {
    $ret = $c->add_entry("Random thought #$$", $in->{all});
  }

  return if had_transport_error($ret);
  print "add_entry got articleID: ", $ret->result, "\n";
  return 1;
}

sub delete_entry {
  my ($opts, $c) = @_;

  my ($id) = $opts->{i} || die "delete requires a journal ID\n";
  my $ret = $c->delete_entry($id);
  return if had_transport_error($ret);
  print "Deleted article ID '$id'\n";
  return 1;
}

sub edit_entry {
  my ($opts, $c, $in) = @_;

  $in ||= parse_input(); # add_entry may have already read STDIN

  unless ($in->{id}) {
    # warn("No article ID\n");
    return add_entry($opts, $c, $in);
  }

  my $ret = $c->modify_entry($in->{id},
                 subject => $in->{subject},
                 body => $in->{body},
                );

  return if had_transport_error($ret);

  print "Updated article $in->{id}\n";

  return 1;
}

sub get_entry {
  my ($opts, $c) = @_;

  my $id = $opts->{i} || die "get_entry requires a journal ID\n";
  my $ret = $c->get_entry($id);
  return if had_transport_error($ret);

  if (my $hr = $ret->result) {
    while (my ($k,$v) = each %{$hr}) {
      print "$k: $v\n";
    }

  } else {
    warn ("Couldn't fetch journal entry '$id'\n");
    return;
  }
  return 1;
}

sub list_entries {
  my ($opts, $c) = @_;
  my ($uid, $limit) = (($opts->{u} || &UID), $opts->{l});

  my $ret = $c->get_entries($uid, $limit);
  return if had_transport_error($ret);

  my $ar = $ret->result;
  for my $row (@{$ar}) {
    while (my ($k,$v) = each %{$row}) {
      print "$k: $v\n";
    }
    print "\n";
  }

  return 1;
}

sub parse_input {
  my %rec;

  my $last_field = 'all';
  while (defined ($_ = <STDIN>)) {
    chomp($_);
    if (/^(\w+):\s*(.*)/) {
      $last_field = $1;
      $rec{$last_field} = $2;
    } else {
      $rec{$last_field} .= "\n$_";
    }
  }

  return \%rec;
}

sub bakeUserCookie {
  my ($uid, $pw) = @_;
  my $c = $uid . "::" . md5_hex($pw);
  $c =~ s/(.)/sprintf("%%%02x", ord($1))/ge;
  $c =~ s/%/%25/g;
  return $c;
}

sub had_transport_error {
  my ($ret) = @_;

  if ($ret->fault) {
    warn ("Oops: ", $ret->faultString, "\n");
    return 1;
  }

  return;
}

To post:

• M-x load-file
• new buffer with "id:\nsubject:\nbody:";
• add blog content to buffer
• M-x t s to publish blog to use.perl