bioperl.lisp

   1 ;;
   2 ;; $Id: bioperl.lisp,v 1.31 2007-03-27 12:43:27 heikki Exp $
   3 ;;
   4 ;; Perl mode set up
   5
   6 (assoc "\\.pl$" auto-mode-alist)
   7 (setq auto-mode-alist (cons '("\\.pl$" . perl-mode) auto-mode-alist))
   8
   9 (assoc "\\.pm$" auto-mode-alist)
  10 (setq auto-mode-alist (cons '("\\.pm$" . perl-mode) auto-mode-alist))
  11
  12 (defun perl-insert-start ()
  13   "Places #!..perl at the start of the script"
  14   (interactive)
  15   (goto-char (point-min))
  16   (insert "#!/usr/local/bin/perl\n"))
  17
  18
  19 (defun bioperl-object-start (perl-object-name perl-caretaker-name caretaker-email)
  20   "Places standard bioperl object notation headers and footers"
  21   (interactive "sName of Object: \nsName of caretaker: \nsEmail: ")
  22   (insert "# $Id: bioperl.lisp,v 1.31 2007-03-27 12:43:27 heikki Exp $\n#\n# BioPerl module for " perl-object-name "\n#\n# Cared for by " perl-caretaker-name " <" caretaker-email ">\n#\n# Copyright " perl-caretaker-name "\n#\n# You may distribute this module under the same terms as perl itself\n\n")
  23   (insert "# POD documentation - main docs before the code\n\n")
  24   (insert "=head1 NAME\n\n" perl-object-name " - DESCRIPTION of Object\n\n")
  25   (insert "=head1 SYNOPSIS\n\nGive standard usage here\n\n")
  26   (insert "=head1 DESCRIPTION\n\nDescribe the object here\n\n")
  27   (insert "=head1 FEEDBACK\n\n=head2 Mailing Lists\n\n")
  28   (insert "User feedback is an integral part of the evolution of this and other\nBioperl modules. Send your comments and suggestions preferably to\nthe Bioperl mailing list.  Your participation is much appreciated.\n\n")
  29   (insert "  bioperl-l@bioperl.org                  - General discussion\n  http://bioperl.org/wiki/Mailing_lists  - About the mailing lists\n\n")
  30   (insert "=head2 Reporting Bugs\n\nReport bugs to the Bioperl bug tracking system to help us keep track\nof the bugs and their resolution. Bug reports can be submitted via\nthe web:\n\n")
  31   (insert "  http://bugzilla.open-bio.org/\n\n")
  32   (insert "=head1 AUTHOR - " perl-caretaker-name "\n\nEmail " caretaker-email "\n\nDescribe contact details here\n\n")
  33   (insert "=head1 CONTRIBUTORS\n\nAdditional contributors names and emails here\n\n")
  34   (insert "=head1 APPENDIX\n\nThe rest of the documentation details each of the object methods.\nInternal methods are usually preceded with a _\n\n=cut\n\n")
  35   (insert "\n# Let the code begin...\n\n")
  36   (insert "\npackage " perl-object-name ";\n")
  37   (insert "use strict;\n")
  38   (insert "\n# Object preamble - inherits from Bio::Root::Root\n")
  39   (insert "\nuse Bio::Root::Root;\n\n")
  40   (insert "\nuse base qw(Bio::Root::Root );\n\n")
  41   (insert "=head2 new\n\n Title   : new\n Usage   : my $obj = new "
  42           perl-object-name "();\n Function: Builds a new "
  43           perl-object-name " object \n Returns : an instance of "
  44           perl-object-name "\n Args    :\n\n\n=cut\n\n")
  45   (insert "sub new {\n  my($class,@args) = @_;\n\n  my $self = $class->SUPER::new(@args);\n  return $self;\n}\n")
  46   (insert "\n\n1;")
  47   )
  48
  49 (defun bioperl-interface-start (perl-object-name perl-caretaker-name
  50                                                  caretaker-email)
  51   "Places standard bioperl object notation headers and footers"
  52   (interactive "sName of Object: \nsName of caretaker: \nsEmail: ")
  53   (insert "# $Id $\n#\n# BioPerl module for " perl-object-name "\n#\n# Cared for by " perl-caretaker-name " <" caretaker-email ">\n#\n# Copyright " perl-caretaker-name "\n#\n# You may distribute this module under the same terms as perl itself\n\n")
  54   (insert "# POD documentation - main docs before the code\n\n")
  55   (insert "=head1 NAME\n\n" perl-object-name " - DESCRIPTION of Interface\n\n")
  56   (insert "=head1 SYNOPSIS\n\nGive standard usage here\n\n")
  57   (insert "=head1 DESCRIPTION\n\nDescribe the interface here\n\n")
  58   (insert "=head1 FEEDBACK\n\n=head2 Mailing Lists\n\n")
  59   (insert "User feedback is an integral part of the evolution of this and other\nBioperl modules. Send your comments and suggestions preferably to\nthe Bioperl mailing list.  Your participation is much appreciated.\n\n")
  60   (insert "  bioperl-l@bioperl.org                  - General discussion\n  http://bioperl.org/wiki/Mailing_lists  - About the mailing lists\n\n")
  61   (insert "=head2 Reporting Bugs\n\nReport bugs to the Bioperl bug tracking system to help us keep track\nof the bugs and their resolution. Bug reports can be submitted via\nemail or the web:\n\n")
  62   (insert "  http://bugzilla.open-bio.org/\n\n")
  63   (insert "=head1 AUTHOR - " perl-caretaker-name "\n\nEmail " caretaker-email "\n\nDescribe contact details here\n\n")
  64   (insert "=head1 CONTRIBUTORS\n\nAdditional contributors names and emails here\n\n")
  65   (insert "=head1 APPENDIX\n\nThe rest of the documentation details each of the object methods.\nInternal methods are usually preceded with a _\n\n=cut\n\n")
  66   (insert "\n# Let the code begin...\n\n")
  67   (insert "\npackage " perl-object-name ";\n")
  68   (insert "use strict;\n\nuse Bio::Root::RootI;\n\n")
  69   (insert "use base qw( Bio::Root::RootI );")
  70   (insert "\n\n1;")
  71   )
  72
  73
  74 (defun bioperl-method (method-name)
  75   "puts in a bioperl method complete with pod boiler-plate"
  76   (interactive "smethod name:")
  77   (insert "=head2 " method-name "\n\n Title   : " method-name "\n Usage   :\n Function:\n Example :\n Returns : \n Args    :\n\n\n=cut\n\n")
  78   (insert "sub " method-name "{\n   my ($self,@args) = @_;\n")
  79   (save-excursion
  80     (insert "\n\n}\n"))
  81   )
  82
  83
  84 (defun bioperl-getset (field-name)
  85   "puts in a bioperl method for a get/set method complete with pod boiler-plate"
  86   (interactive "sfield name:")
  87   (insert "=head2 " field-name "\n\n Title   : " field-name "\n Usage   : $obj->" field-name "($newval)\n Function: \n Example : \n Returns : value of " field-name " (a scalar)\n Args    : on set, new value (a scalar or undef, optional)\n\n\n=cut\n\n")
  88   (insert "sub " field-name "{\n    my $self = shift;\n\n    return $self->{'" field-name "'} = shift if @_;\n    return $self->{'" field-name "'};")
  89   (insert "\n}\n"))
  90
  91 (defun bioperl-array-getset (field-name class-name)
  92   "puts in a bioperl method for array get/add/remove methods complete with pod boiler-plate"
  93   (interactive "sarray base object: \nstype of element: ")
  94   (insert "=head2 get_" field-name "s\n\n Title   : get_" field-name "s\n Usage   : @arr = get_" field-name "s()\n Function: Get the list of " field-name "(s) for this object.\n Example :\n Returns : An array of " class-name " objects\n Args    :\n\n\n=cut\n\n")
  95   (insert "sub get_" field-name "s{\n    my $self = shift;\n\n    return @{$self->{'_" field-name "s'}} if exists($self->{'_" field-name "s'});\n    return ();\n}\n\n")
  96   (insert "=head2 add_" field-name "\n\n Title   : add_" field-name "\n Usage   :\n Function: Add one or more " field-name "(s) to this object.\n Example :\n Returns : \n Args    : One or more " class-name " objects.\n\n\n=cut\n\n")
  97   (insert "sub add_" field-name "{\n    my $self = shift;\n\n    $self->{'_" field-name "s'} = [] unless exists($self->{'_" field-name "s'});\n    push(@{$self->{'_" field-name "s'}}, @_);\n}\n\n")
  98   (insert "=head2 remove_" field-name "s\n\n Title   : remove_" field-name "s\n Usage   :\n Function: Remove all " field-name "s for this class.\n Example :\n Returns : The list of previous " field-name "s as an array of\n           " class-name " objects.\n Args    :\n\n\n=cut\n\n")
  99   (insert "sub remove_" field-name "s{\n    my $self = shift;\n\n    my @arr = $self->get_" field-name "s();\n    $self->{'_" field-name "s'} = [];\n    return @arr;\n}\n\n"))
 100
 101
 102 (defun bioperl-abstract-method (method-name)
 103   "puts in a bioperl abstract method for interface classes"
 104   (interactive "smethod-name:")
 105   (save-excursion
 106   (insert "=head2 " method-name "\n\n Title   : " method-name "\n Usage   :\n Function:\n Example :\n Returns : \n Args    :\n\n\n=cut\n\n")
 107   (insert "sub " method-name "{\n   my ($self) = @_;\n\n    $self->throw(\"Abstract method " method-name " implementing class did not provide method\");\n")
 108     (insert "\n\n}\n")
 109     )
 110   )
 111
 112
 113
 114 (setq perl-mode-hook
 115       '(lambda ()
 116          (define-key perl-mode-map "\C-c\C-h" 'perl-insert-start)
 117          (define-key perl-mode-map "\C-c\C-b" 'bioperl-object-start)
 118          (define-key perl-mode-map "\C-c\C-i" 'bioperl-interface-start)
 119          (define-key perl-mode-map "\C-c\C-v" 'bioperl-getset)
 120          (define-key perl-mode-map "\C-c\C-r" 'bioperl-arrray-getset)
 121          (define-key perl-mode-map "\C-c\C-b" 'bioperl-method)
 122          (define-key perl-mode-map "\C-c\C-a\C-m" 'bioperl-abstract-method)
 123          (define-key perl-mode-map "\C-c\C-z" 'compile)
 124          (define-key perl-mode-map [menu-bar] (make-sparse-keymap))
 125          (define-key perl-mode-map [menu-bar p]
 126            (cons "BioPerl" (make-sparse-keymap "BioPerl")))
 127          (define-key perl-mode-map [menu-bar p perl-script-start]
 128            '("Insert script template" . perl-script-start))
 129          (define-key perl-mode-map [menu-bar p bioperl-object-start]
 130            '("bioperl object template" . bioperl-object-start))
 131          (define-key perl-mode-map [menu-bar p bioperl-interface-start]
 132            '("bioperl interface template" . bioperl-interface-start))
 133          (define-key perl-mode-map [menu-bar p bioperl-getset]
 134            '("bioperl field func" . bioperl-getset))
 135          (define-key perl-mode-map [menu-bar p bioperl-array-getset]
 136            '("bioperl array get/add/remove" . bioperl-array-getset))
 137          (define-key perl-mode-map [menu-bar p bioperl-method]
 138            '("bioperl method" . bioperl-method))
 139          ))
 140