Mercurial > hg > xemacs-beta
annotate lisp/package-admin.el @ 4952:19a72041c5ed
Mule-izing, various fixes related to char * arguments
-------------------- ChangeLog entries follow: --------------------
modules/ChangeLog addition:
2010-01-26 Ben Wing <ben@xemacs.org>
* postgresql/postgresql.c:
* postgresql/postgresql.c (CHECK_LIVE_CONNECTION):
* postgresql/postgresql.c (print_pgresult):
* postgresql/postgresql.c (Fpq_conn_defaults):
* postgresql/postgresql.c (Fpq_connectdb):
* postgresql/postgresql.c (Fpq_connect_start):
* postgresql/postgresql.c (Fpq_result_status):
* postgresql/postgresql.c (Fpq_res_status):
Mule-ize large parts of it.
2010-01-26 Ben Wing <ben@xemacs.org>
* ldap/eldap.c (print_ldap):
* ldap/eldap.c (allocate_ldap):
Use write_ascstring().
src/ChangeLog addition:
2010-01-26 Ben Wing <ben@xemacs.org>
* alloc.c:
* alloc.c (build_ascstring):
* alloc.c (build_msg_cistring):
* alloc.c (staticpro_1):
* alloc.c (staticpro_name):
* alloc.c (staticpro_nodump_1):
* alloc.c (staticpro_nodump_name):
* alloc.c (unstaticpro_nodump_1):
* alloc.c (mcpro_1):
* alloc.c (mcpro_name):
* alloc.c (object_memory_usage_stats):
* alloc.c (common_init_alloc_early):
* alloc.c (init_alloc_once_early):
* buffer.c (print_buffer):
* buffer.c (vars_of_buffer):
* buffer.c (common_init_complex_vars_of_buffer):
* buffer.c (init_initial_directory):
* bytecode.c (invalid_byte_code):
* bytecode.c (print_compiled_function):
* bytecode.c (mark_compiled_function):
* chartab.c (print_table_entry):
* chartab.c (print_char_table):
* config.h.in:
* console-gtk.c:
* console-gtk.c (gtk_device_to_console_connection):
* console-gtk.c (gtk_semi_canonicalize_console_connection):
* console-gtk.c (gtk_canonicalize_console_connection):
* console-gtk.c (gtk_semi_canonicalize_device_connection):
* console-gtk.c (gtk_canonicalize_device_connection):
* console-stream.c (stream_init_frame_1):
* console-stream.c (vars_of_console_stream):
* console-stream.c (init_console_stream):
* console-x.c (x_semi_canonicalize_console_connection):
* console-x.c (x_semi_canonicalize_device_connection):
* console-x.c (x_canonicalize_device_connection):
* console-x.h:
* data.c (eq_with_ebola_notice):
* data.c (Fsubr_interactive):
* data.c (Fnumber_to_string):
* data.c (digit_to_number):
* device-gtk.c (gtk_init_device):
* device-msw.c (print_devmode):
* device-x.c (x_event_name):
* dialog-msw.c (handle_directory_dialog_box):
* dialog-msw.c (handle_file_dialog_box):
* dialog-msw.c (vars_of_dialog_mswindows):
* doc.c (weird_doc):
* doc.c (Fsnarf_documentation):
* doc.c (vars_of_doc):
* dumper.c (pdump):
* dynarr.c:
* dynarr.c (Dynarr_realloc):
* editfns.c (Fuser_real_login_name):
* editfns.c (get_home_directory):
* elhash.c (print_hash_table_data):
* elhash.c (print_hash_table):
* emacs.c (main_1):
* emacs.c (vars_of_emacs):
* emodules.c:
* emodules.c (_emodules_list):
* emodules.c (Fload_module):
* emodules.c (Funload_module):
* emodules.c (Flist_modules):
* emodules.c (find_make_module):
* emodules.c (attempt_module_delete):
* emodules.c (emodules_load):
* emodules.c (emodules_doc_subr):
* emodules.c (emodules_doc_sym):
* emodules.c (syms_of_module):
* emodules.c (vars_of_module):
* emodules.h:
* eval.c (print_subr):
* eval.c (signal_call_debugger):
* eval.c (build_error_data):
* eval.c (signal_error):
* eval.c (maybe_signal_error):
* eval.c (signal_continuable_error):
* eval.c (maybe_signal_continuable_error):
* eval.c (signal_error_2):
* eval.c (maybe_signal_error_2):
* eval.c (signal_continuable_error_2):
* eval.c (maybe_signal_continuable_error_2):
* eval.c (signal_ferror):
* eval.c (maybe_signal_ferror):
* eval.c (signal_continuable_ferror):
* eval.c (maybe_signal_continuable_ferror):
* eval.c (signal_ferror_with_frob):
* eval.c (maybe_signal_ferror_with_frob):
* eval.c (signal_continuable_ferror_with_frob):
* eval.c (maybe_signal_continuable_ferror_with_frob):
* eval.c (syntax_error):
* eval.c (syntax_error_2):
* eval.c (maybe_syntax_error):
* eval.c (sferror):
* eval.c (sferror_2):
* eval.c (maybe_sferror):
* eval.c (invalid_argument):
* eval.c (invalid_argument_2):
* eval.c (maybe_invalid_argument):
* eval.c (invalid_constant):
* eval.c (invalid_constant_2):
* eval.c (maybe_invalid_constant):
* eval.c (invalid_operation):
* eval.c (invalid_operation_2):
* eval.c (maybe_invalid_operation):
* eval.c (invalid_change):
* eval.c (invalid_change_2):
* eval.c (maybe_invalid_change):
* eval.c (invalid_state):
* eval.c (invalid_state_2):
* eval.c (maybe_invalid_state):
* eval.c (wtaerror):
* eval.c (stack_overflow):
* eval.c (out_of_memory):
* eval.c (print_multiple_value):
* eval.c (issue_call_trapping_problems_warning):
* eval.c (backtrace_specials):
* eval.c (backtrace_unevalled_args):
* eval.c (Fbacktrace):
* eval.c (warn_when_safe):
* event-Xt.c (modwarn):
* event-Xt.c (modbarf):
* event-Xt.c (check_modifier):
* event-Xt.c (store_modifier):
* event-Xt.c (emacs_Xt_format_magic_event):
* event-Xt.c (describe_event):
* event-gtk.c (dragndrop_data_received):
* event-gtk.c (store_modifier):
* event-gtk.c (gtk_reset_modifier_mapping):
* event-msw.c (dde_eval_string):
* event-msw.c (Fdde_alloc_advise_item):
* event-msw.c (mswindows_dde_callback):
* event-msw.c (FROB):
* event-msw.c (emacs_mswindows_format_magic_event):
* event-stream.c (external_debugging_print_event):
* event-stream.c (execute_help_form):
* event-stream.c (vars_of_event_stream):
* events.c (print_event_1):
* events.c (print_event):
* events.c (event_equal):
* extents.c (print_extent_1):
* extents.c (print_extent):
* extents.c (vars_of_extents):
* faces.c (print_face):
* faces.c (complex_vars_of_faces):
* file-coding.c:
* file-coding.c (print_coding_system):
* file-coding.c (print_coding_system_in_print_method):
* file-coding.c (default_query_method):
* file-coding.c (find_coding_system):
* file-coding.c (make_coding_system_1):
* file-coding.c (chain_print):
* file-coding.c (undecided_print):
* file-coding.c (gzip_print):
* file-coding.c (vars_of_file_coding):
* file-coding.c (complex_vars_of_file_coding):
* fileio.c:
* fileio.c (report_file_type_error):
* fileio.c (report_error_with_errno):
* fileio.c (report_file_error):
* fileio.c (barf_or_query_if_file_exists):
* fileio.c (vars_of_fileio):
* floatfns.c (matherr):
* fns.c (print_bit_vector):
* fns.c (Fmapconcat):
* fns.c (add_suffix_to_symbol):
* fns.c (add_prefix_to_symbol):
* frame-gtk.c:
* frame-gtk.c (Fgtk_window_id):
* frame-x.c (def):
* frame-x.c (x_cde_transfer_callback):
* frame.c:
* frame.c (Fmake_frame):
* gc.c (show_gc_cursor_and_message):
* gc.c (vars_of_gc):
* glyphs-eimage.c (png_instantiate):
* glyphs-eimage.c (tiff_instantiate):
* glyphs-gtk.c (gtk_print_image_instance):
* glyphs-msw.c (mswindows_print_image_instance):
* glyphs-x.c (x_print_image_instance):
* glyphs-x.c (update_widget_face):
* glyphs.c (make_string_from_file):
* glyphs.c (print_image_instance):
* glyphs.c (signal_image_error):
* glyphs.c (signal_image_error_2):
* glyphs.c (signal_double_image_error):
* glyphs.c (signal_double_image_error_2):
* glyphs.c (xbm_mask_file_munging):
* glyphs.c (pixmap_to_lisp_data):
* glyphs.h:
* gui.c (gui_item_display_flush_left):
* hpplay.c (player_error_internal):
* hpplay.c (myHandler):
* intl-win32.c:
* intl-win32.c (langcode_to_lang):
* intl-win32.c (sublangcode_to_lang):
* intl-win32.c (Fmswindows_get_locale_info):
* intl-win32.c (lcid_to_locale_mule_or_no):
* intl-win32.c (mswindows_multibyte_to_unicode_print):
* intl-win32.c (complex_vars_of_intl_win32):
* keymap.c:
* keymap.c (print_keymap):
* keymap.c (ensure_meta_prefix_char_keymapp):
* keymap.c (Fkey_description):
* keymap.c (Ftext_char_description):
* lisp.h:
* lisp.h (struct):
* lisp.h (DECLARE_INLINE_HEADER):
* lread.c (Fload_internal):
* lread.c (locate_file):
* lread.c (read_escape):
* lread.c (read_raw_string):
* lread.c (read1):
* lread.c (read_list):
* lread.c (read_compiled_function):
* lread.c (init_lread):
* lrecord.h:
* marker.c (print_marker):
* marker.c (marker_equal):
* menubar-msw.c (displayable_menu_item):
* menubar-x.c (command_builder_operate_menu_accelerator):
* menubar.c (vars_of_menubar):
* minibuf.c (reinit_complex_vars_of_minibuf):
* minibuf.c (complex_vars_of_minibuf):
* mule-charset.c (Fmake_charset):
* mule-charset.c (complex_vars_of_mule_charset):
* mule-coding.c (iso2022_print):
* mule-coding.c (fixed_width_query):
* number.c (bignum_print):
* number.c (ratio_print):
* number.c (bigfloat_print):
* number.c (bigfloat_finalize):
* objects-msw.c:
* objects-msw.c (mswindows_color_to_string):
* objects-msw.c (mswindows_color_list):
* objects-tty.c:
* objects-tty.c (tty_font_list):
* objects-tty.c (tty_find_charset_font):
* objects-xlike-inc.c (xft_find_charset_font):
* objects-xlike-inc.c (endif):
* print.c:
* print.c (write_istring):
* print.c (write_ascstring):
* print.c (Fterpri):
* print.c (Fprint):
* print.c (print_error_message):
* print.c (print_vector_internal):
* print.c (print_cons):
* print.c (print_string):
* print.c (printing_unreadable_object):
* print.c (print_internal):
* print.c (print_float):
* print.c (print_symbol):
* process-nt.c (mswindows_report_winsock_error):
* process-nt.c (nt_canonicalize_host_name):
* process-unix.c (unix_canonicalize_host_name):
* process.c (print_process):
* process.c (report_process_error):
* process.c (report_network_error):
* process.c (make_process_internal):
* process.c (Fstart_process_internal):
* process.c (status_message):
* process.c (putenv_internal):
* process.c (vars_of_process):
* process.h:
* profile.c (vars_of_profile):
* rangetab.c (print_range_table):
* realpath.c (vars_of_realpath):
* redisplay.c (vars_of_redisplay):
* search.c (wordify):
* search.c (Freplace_match):
* sheap.c (sheap_adjust_h):
* sound.c (report_sound_error):
* sound.c (Fplay_sound_file):
* specifier.c (print_specifier):
* symbols.c (Fsubr_name):
* symbols.c (do_symval_forwarding):
* symbols.c (set_default_buffer_slot_variable):
* symbols.c (set_default_console_slot_variable):
* symbols.c (store_symval_forwarding):
* symbols.c (default_value):
* symbols.c (defsymbol_massage_name_1):
* symbols.c (defsymbol_massage_name_nodump):
* symbols.c (defsymbol_massage_name):
* symbols.c (defsymbol_massage_multiword_predicate_nodump):
* symbols.c (defsymbol_massage_multiword_predicate):
* symbols.c (defsymbol_nodump):
* symbols.c (defsymbol):
* symbols.c (defkeyword):
* symbols.c (defkeyword_massage_name):
* symbols.c (check_module_subr):
* symbols.c (deferror_1):
* symbols.c (deferror):
* symbols.c (deferror_massage_name):
* symbols.c (deferror_massage_name_and_message):
* symbols.c (defvar_magic):
* symeval.h:
* symeval.h (DEFVAR_SYMVAL_FWD):
* sysdep.c:
* sysdep.c (init_system_name):
* sysdll.c:
* sysdll.c (MAYBE_PREPEND_UNDERSCORE):
* sysdll.c (dll_function):
* sysdll.c (dll_variable):
* sysdll.c (dll_error):
* sysdll.c (dll_open):
* sysdll.c (dll_close):
* sysdll.c (image_for_address):
* sysdll.c (my_find_image):
* sysdll.c (search_linked_libs):
* sysdll.h:
* sysfile.h:
* sysfile.h (DEFAULT_DIRECTORY_FALLBACK):
* syswindows.h:
* tests.c (DFC_CHECK_LENGTH):
* tests.c (DFC_CHECK_CONTENT):
* tests.c (Ftest_hash_tables):
* text.c (vars_of_text):
* text.h:
* tooltalk.c (tt_opnum_string):
* tooltalk.c (tt_message_arg_ival_string):
* tooltalk.c (Ftooltalk_default_procid):
* tooltalk.c (Ftooltalk_default_session):
* tooltalk.c (init_tooltalk):
* tooltalk.c (vars_of_tooltalk):
* ui-gtk.c (Fdll_load):
* ui-gtk.c (type_to_marshaller_type):
* ui-gtk.c (Fgtk_import_function_internal):
* ui-gtk.c (emacs_gtk_object_printer):
* ui-gtk.c (emacs_gtk_boxed_printer):
* unicode.c (unicode_to_ichar):
* unicode.c (unicode_print):
* unicode.c (unicode_query):
* unicode.c (vars_of_unicode):
* unicode.c (complex_vars_of_unicode):
* win32.c:
* win32.c (mswindows_report_process_error):
* window.c (print_window):
* xemacs.def.in.in:
BASIC IDEA: Further fixing up uses of char * and CIbyte *
to reflect their actual semantics; Mule-izing some code;
redoing of the not-yet-working code to handle message translation.
Clean up code to handle message-translation (not yet working).
Create separate versions of build_msg_string() for working with
Ibyte *, CIbyte *, and Ascbyte * arguments. Assert that Ascbyte *
arguments are pure-ASCII. Make build_msg_string() be the same
as build_msg_ascstring(). Create same three versions of GETTEXT()
and DEFER_GETTEXT(). Also create build_defer_string() and
variants for the equivalent of DEFER_GETTEXT() when building a
string. Remove old CGETTEXT(). Clean up code where GETTEXT(),
DEFER_GETTEXT(), build_msg_string(), etc. was being called and
introduce some new calls to build_msg_string(), etc. Remove
GETTEXT() from calls to weird_doc() -- we assume that the
message snarfer knows about weird_doc(). Remove uses of
DEFER_GETTEXT() from error messages in sysdep.c and instead use
special comments /* @@@begin-snarf@@@ */ and /* @@@end-snarf@@@ */
that the message snarfer presumably knows about.
Create build_ascstring() and use it in many instances in place
of build_string(). The purpose of having Ascbyte * variants is
to make the code more self-documenting in terms of what sort of
semantics is expected for char * strings. In fact in the process
of looking for uses of build_string(), much improperly Mule-ized
was discovered.
Mule-ize a lot of code as described in previous paragraph,
e.g. in sysdep.c.
Make the error functions take Ascbyte * strings and fix up a
couple of places where non-pure-ASCII strings were being passed in
(file-coding.c, mule-coding.c, unicode.c). (It's debatable whether
we really need to make the error functions work this way. It
helps catch places where code is written in a way that message
translation won't work, but we may well never implement message
translation.)
Make staticpro() and friends take Ascbyte * strings instead of
raw char * strings. Create a const_Ascbyte_ptr dynarr type
to describe what's held by staticpro_names[] and friends,
create pdump descriptions for const_Ascbyte_ptr dynarrs, and
use them in place of specially-crafted staticpro descriptions.
Mule-ize certain other functions (e.g. x_event_name) by correcting
raw use of char * to Ascbyte *, Rawbyte * or another such type,
and raw use of char[] buffers to another type (usually Ascbyte[]).
Change many uses of write_c_string() to write_msg_string(),
write_ascstring(), etc.
Mule-ize emodules.c, emodules.h, sysdll.h.
Fix some un-Mule-ized code in intl-win32.c.
A comment in event-Xt.c and the limitations of the message
snarfer (make-msgfile or whatever) is presumably incorrect --
it should be smart enough to handle function calls spread over
more than one line. Clean up code in event-Xt.c that was
written awkwardly for this reason.
In config.h.in, instead of NEED_ERROR_CHECK_TYPES_INLINES,
create a more general XEMACS_DEFS_NEEDS_INLINE_DECLS to
indicate when inlined functions need to be declared in
xemacs.defs.in.in, and make use of it in xemacs.defs.in.in.
We need to do this because postgresql.c now calls qxestrdup(),
which is an inline function.
Make nconc2() and other such functions MODULE_API and put
them in xemacs.defs.in.in since postgresql.c now uses them.
Clean up indentation in lread.c and a few other places.
In text.h, document ASSERT_ASCTEXT_ASCII() and
ASSERT_ASCTEXT_ASCII_LEN(), group together the stand-in
encodings and add some more for DLL symbols, function and
variable names, etc.
| author | Ben Wing <ben@xemacs.org> |
|---|---|
| date | Tue, 26 Jan 2010 23:22:30 -0600 |
| parents | 3c92890f3750 |
| children | 308d34e9f07d |
| rev | line source |
|---|---|
| 428 | 1 ;;; package-admin.el --- Installation and Maintenance of XEmacs packages |
| 2 | |
| 3 ;; Copyright (C) 1997 by Free Software Foundation, Inc. | |
| 1410 | 4 ;; Copyright (C) 2003, Steve Youngs. |
| 428 | 5 |
| 6 ;; Author: SL Baur <steve@xemacs.org> | |
| 7 ;; Keywords: internal | |
| 8 | |
| 9 ;; This file is part of XEmacs. | |
| 10 | |
| 11 ;; XEmacs is free software; you can redistribute it and/or modify it | |
| 12 ;; under the terms of the GNU General Public License as published by | |
| 13 ;; the Free Software Foundation; either version 2, or (at your option) | |
| 14 ;; any later version. | |
| 15 | |
| 16 ;; XEmacs is distributed in the hope that it will be useful, but | |
| 17 ;; WITHOUT ANY WARRANTY; without even the implied warranty of | |
| 18 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU | |
| 19 ;; General Public License for more details. | |
| 20 | |
| 21 ;; You should have received a copy of the GNU General Public License | |
| 22 ;; along with XEmacs; see the file COPYING. If not, write to the Free | |
| 23 ;; Software Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA | |
| 24 ;; 02111-1307, USA. | |
| 25 | |
| 26 ;;; Synched up with: Not in FSF | |
| 27 | |
| 28 ;;; Commentary: | |
| 29 | |
| 30 ;; First pass at lisp front end to package maintenance. | |
| 31 | |
| 32 ;;; Code: | |
| 33 | |
| 34 (require 'config) | |
| 35 | |
| 36 (defvar package-admin-xemacs (concat invocation-directory invocation-name) | |
| 37 "Location of XEmacs binary to use.") | |
| 38 | |
| 39 (defvar package-admin-temp-buffer "*Package Output*" | |
| 40 "Temporary buffer where output of backend commands is saved.") | |
| 41 | |
| 42 (defvar package-admin-install-function (if (eq system-type 'windows-nt) | |
| 43 'package-admin-install-function-mswindows | |
| 44 'package-admin-default-install-function) | |
| 45 "The function to call to install a package. | |
| 444 | 46 Three args are passed: FILENAME PKG-DIR BUFFER |
| 428 | 47 Install package FILENAME into directory PKG-DIR, with any messages output |
| 444 | 48 to buffer BUFFER.") |
| 428 | 49 |
| 50 (defvar package-admin-error-messages '( | |
| 51 "No space left on device" | |
| 52 "No such file or directory" | |
| 53 "Filename too long" | |
| 54 "Read-only file system" | |
| 55 "File too large" | |
| 56 "Too many open files" | |
| 57 "Not enough space" | |
| 58 "Permission denied" | |
| 59 "Input/output error" | |
| 60 "Out of memory" | |
| 61 "Unable to create directory" | |
| 62 "Directory checksum error" | |
| 63 "Cannot exclusively open file" | |
| 64 "corrupted file" | |
| 65 "incomplete .* tree" | |
| 66 "Bad table" | |
| 67 "corrupt input" | |
| 68 "invalid compressed data" | |
| 69 "too many leaves in Huffman tree" | |
| 70 "not a valid zip file" | |
| 71 "first entry not deflated or stored" | |
| 72 "encrypted file --" | |
| 73 "unexpected end of file" | |
| 74 ) | |
| 75 "Regular expressions of possible error messages. | |
| 76 After each package extraction, the `package-admin-temp-buffer' buffer is | |
| 77 scanned for these messages. An error code is returned if one of these are | |
| 78 found. | |
| 79 | |
| 80 This is awful, but it exists because error return codes aren't reliable | |
| 81 under MS Windows.") | |
| 82 | |
| 83 (defvar package-admin-tar-filename-regexps | |
| 84 '( | |
| 85 ;; GNU tar: | |
| 86 ;; drwxrwxr-x john/doe 123 1997-02-18 15:48 pathname | |
| 87 "\\S-+\\s-+[-a-z0-9_/]+\\s-+[0-9]+\\s-+[-0-9]+\\s-+[0-9:]+\\s-+\\(\\S-.*\\)" | |
| 88 ;; HP-UX & SunOS tar: | |
| 89 ;; rwxrwxr-x 501/501 123 Feb 18 15:46 1997 pathname | |
| 90 ;; Solaris tar (phooey!): | |
| 91 ;; rwxrwxr-x501/501 123 Feb 18 15:46 1997 pathname | |
| 92 ;; AIX tar: | |
| 93 ;; -rw-r--r-- 147 1019 32919 Mar 26 12:00:09 1992 pathname | |
| 94 "\\S-+\\s-*[-a-z0-9_]+[/ ][-a-z0-9_]+\\s-+[0-9]+\\s-+[a-z][a-z][a-z]\\s-+[0-9]+\\s-+[0-9:]+\\s-+[0-9]+\\s-+\\(\\S-.*\\)" | |
| 95 | |
| 96 ;; djtar: | |
| 97 ;; drwx Aug 31 02:01:41 1998 123 pathname | |
| 98 "\\S-+\\s-+[a-z][a-z][a-z]\\s-+[0-9]+\\s-+[0-9:]+\\s-+[0-9]+\\s-+[0-9]+\\s-+\\(\\S-.*\\)" | |
| 99 | |
| 100 ) | |
| 101 "List of regexps to use to search for tar filenames. | |
| 102 Note that \"\\(\" and \"\\)\" must be used to delimit the pathname (as | |
| 103 match #1). Don't put \"^\" to match the beginning of the line; this | |
| 104 is already implicit, as `looking-at' is used. Filenames can, | |
| 105 unfortunately, contain spaces, so be careful in constructing any | |
| 106 regexps.") | |
| 107 | |
| 628 | 108 (defvar package-install-hook nil |
| 109 "*List of hook functions to be called when a new package is successfully | |
| 110 installed. The hook function is passed two arguments: the package name, and | |
| 111 the install directory.") | |
| 112 | |
| 113 (defvar package-delete-hook nil | |
| 114 "*List of hook functions to be called when a package is deleted. The | |
| 115 hook is called *before* the package is deleted. The hook function is passed | |
| 116 two arguments: the package name, and the install directory.") | |
| 117 | |
| 444 | 118 (defun package-admin-install-function-mswindows (file pkg-dir buffer) |
| 119 "Install function for mswindows." | |
| 428 | 120 (let ((default-directory (file-name-as-directory pkg-dir))) |
| 121 (unless (file-directory-p default-directory) | |
| 122 (make-directory default-directory t)) | |
| 444 | 123 (call-process "minitar" nil buffer t file))) |
| 428 | 124 |
| 444 | 125 (defun package-admin-default-install-function (filename pkg-dir buffer) |
| 428 | 126 "Default function to install a package. |
| 127 Install package FILENAME into directory PKG-DIR, with any messages output | |
| 444 | 128 to BUFFER." |
| 428 | 129 (let* ((pkg-dir (file-name-as-directory pkg-dir)) |
| 130 (default-directory pkg-dir) | |
| 444 | 131 (filename (expand-file-name filename))) |
| 428 | 132 (unless (file-directory-p pkg-dir) |
| 133 (make-directory pkg-dir t)) | |
| 134 ;; Don't assume GNU tar. | |
| 444 | 135 (if (shell-command (concat "gunzip -c " filename " | tar xvf -") buffer) |
| 428 | 136 0 |
| 1365 | 137 1))) |
| 428 | 138 |
| 1378 | 139 ;; A few things needed by the following 2 functions. |
| 140 (eval-when-compile | |
| 141 (require 'packages) | |
| 142 (autoload 'package-get-info "package-get") | |
| 143 (autoload 'paths-decode-directory-path "find-paths") | |
| 144 (defvar package-get-install-to-user-init-directory)) | |
| 145 | |
| 146 (defun package-admin-find-top-directory (type &optional user-dir) | |
| 147 "Return the top level directory for a package. | |
| 148 | |
| 149 Argument TYPE is a symbol that determines the type of package we're | |
| 150 trying to find a directory for. | |
| 151 | |
| 152 Optional Argument USER-DIR if non-nil use directories off | |
| 3179 | 153 `early-package-directories'. |
| 1378 | 154 |
| 155 If we still can't find a suitable directory, return nil. | |
| 156 | |
| 157 Possible values for TYPE are: | |
| 158 | |
| 159 std == For \"standard\" packages that go in '/xemacs-packages/' | |
| 160 mule == For \"mule\" packages that go in '/mule-packages/' | |
| 161 site == For \"unsupported\" packages that go in '/site-packages/' | |
| 3179 | 162 " |
| 163 (let* ((hierarchies late-package-hierarchies) | |
| 164 | |
| 165 (hierarchy-suffix | |
| 166 (file-name-as-directory | |
| 167 (cond | |
| 168 ((eq type 'std) "xemacs-packages") | |
| 169 ((eq type 'mule) "mule-packages") | |
| 170 ((eq type 'site) "site-packages")))) | |
| 171 (suffix-length (length hierarchy-suffix)) | |
| 1378 | 172 top-dir) |
| 3179 | 173 |
| 174 (if user-dir | |
| 175 (expand-file-name hierarchy-suffix | |
| 176 (if configure-early-package-directories | |
| 177 (car configure-early-package-directories) | |
| 178 user-init-directory)) | |
| 179 | |
| 180 (while hierarchies | |
| 181 (if (string-equal (substring (car hierarchies) (- suffix-length)) | |
| 182 hierarchy-suffix) | |
| 183 (setq top-dir (car hierarchies))) | |
| 184 (setq hierarchies (cdr hierarchies))) | |
| 185 top-dir))) | |
| 186 | |
| 1378 | 187 |
| 188 (defun package-admin-get-install-dir (package &optional pkg-dir) | |
| 189 "Find a suitable installation directory for a package. | |
| 190 | |
| 191 Argument PACKAGE is the package to find a installation directory for. | |
| 192 Optional Argument PKG-DIR, if non-nil is a directory to use for | |
| 193 installation. | |
| 194 | |
| 195 If PKG-DIR is non-nil and writable, return that. Otherwise check to | |
| 196 see if the PACKAGE is already installed and return that location, if | |
| 197 it is writable. Finally, fall back to the `user-init-directory' if | |
| 198 all else fails. As a side effect of installing packages under | |
| 2456 | 199 `user-init-directory' these packages become part of `early-package-hierarchies'." |
| 1378 | 200 ;; If pkg-dir specified, return that if writable. |
| 201 (if (and pkg-dir | |
| 202 (file-writable-p (directory-file-name pkg-dir))) | |
| 428 | 203 pkg-dir |
| 1378 | 204 ;; If the user want her packages under ~/.xemacs/, do so. |
| 205 (let ((type (package-get-info package 'category))) | |
| 206 (if package-get-install-to-user-init-directory | |
| 207 (progn | |
| 208 (cond ((equal type "standard") | |
| 209 (setq pkg-dir (package-admin-find-top-directory 'std 'user-dir))) | |
| 210 ((equal type "mule") | |
| 211 (setq pkg-dir (package-admin-find-top-directory 'mule 'user-dir)))) | |
| 212 pkg-dir) | |
| 213 ;; Maybe the package has been installed before, if so, return | |
| 214 ;; that directory. | |
| 215 (let ((package-feature (intern-soft (concat | |
| 216 (symbol-name package) "-autoloads"))) | |
| 217 autoload-dir) | |
| 218 (when (and (not (eq package 'unknown)) | |
| 219 (featurep package-feature) | |
| 220 (setq autoload-dir (feature-file package-feature)) | |
| 221 (setq autoload-dir (file-name-directory autoload-dir)) | |
| 222 (member autoload-dir (append early-package-load-path late-package-load-path))) | |
| 223 ;; Find the corresponding entry in late-package | |
| 224 (setq pkg-dir | |
| 225 (car-safe (member-if (lambda (h) | |
| 226 (string-match (concat "^" (regexp-quote h)) | |
| 227 autoload-dir)) | |
| 2456 | 228 (append (cdr early-package-hierarchies) late-package-hierarchies))))) |
| 1378 | 229 (if (and pkg-dir |
| 230 (file-writable-p (directory-file-name pkg-dir))) | |
| 231 pkg-dir | |
| 232 ;; OK, the package hasn't been previously installed so we need | |
| 233 ;; to guess where it should go. | |
| 234 (cond ((equal type "standard") | |
| 235 (setq pkg-dir (package-admin-find-top-directory 'std))) | |
| 236 ((equal type "mule") | |
| 237 (setq pkg-dir (package-admin-find-top-directory 'mule))) | |
| 238 (t | |
| 1410 | 239 (error 'invalid-operation |
| 240 "Invalid package type"))) | |
| 1378 | 241 (if (and pkg-dir |
| 242 (file-writable-p (directory-file-name pkg-dir))) | |
| 243 pkg-dir | |
| 244 ;; Oh no! Either we still haven't found a suitable | |
| 245 ;; directory, or we can't write to the one we did find. | |
| 246 ;; Drop back to the `user-init-directory'. | |
| 247 (if (y-or-n-p (format "Directory isn't writable, use %s instead? " | |
| 248 user-init-directory)) | |
| 249 (progn | |
| 250 (cond ((equal type "standard") | |
| 251 (setq pkg-dir (package-admin-find-top-directory 'std 'user-dir))) | |
| 252 ((equal type "mule") | |
| 253 (setq pkg-dir (package-admin-find-top-directory 'mule 'user-dir))) | |
| 254 (t | |
| 1410 | 255 (error 'invalid-operation |
| 256 "Invalid package type"))) | |
| 1378 | 257 ;; Turn on `package-get-install-to-user-init-directory' |
| 258 ;; so we don't get asked for each package we try to | |
| 259 ;; install in this session. | |
| 260 (setq package-get-install-to-user-init-directory t) | |
| 261 pkg-dir) | |
| 262 ;; If we get to here XEmacs can't make up its mind and | |
| 263 ;; neither can the user, nothing left to do except barf. :-( | |
| 1410 | 264 (error 'search-failed |
| 265 (format | |
| 266 "Can't find suitable installation directory for package: %s" | |
| 267 package)))))))))) | |
| 428 | 268 |
| 269 (defun package-admin-get-manifest-file (pkg-topdir package) | |
| 270 "Return the name of the MANIFEST file for package PACKAGE. | |
| 271 Note that PACKAGE is a symbol, and not a string." | |
| 1365 | 272 (let ((dir (file-name-as-directory |
| 273 (expand-file-name "pkginfo" pkg-topdir)))) | |
| 274 (expand-file-name (concat "MANIFEST." (symbol-name package)) dir))) | |
| 428 | 275 |
| 276 (defun package-admin-check-manifest (pkg-outbuf pkg-topdir) | |
| 277 "Check for a MANIFEST.<package> file in the package distribution. | |
| 278 If it doesn't exist, create and write one. | |
| 279 PKG-OUTBUF is the buffer that holds the output from `tar', and PKG-TOPDIR | |
| 280 is the top-level directory under which the package was installed." | |
| 1365 | 281 (let ((manifest-buf " *pkg-manifest*") |
|
4720
3c92890f3750
Add `file-system-ignore-case-p', use it.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3179
diff
changeset
|
282 (case-fold-search (file-system-ignore-case-p pkg-topdir)) |
| 1365 | 283 regexp package-name pathname regexps) |
|
4720
3c92890f3750
Add `file-system-ignore-case-p', use it.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3179
diff
changeset
|
284 (save-excursion ;; Probably redundant. |
|
3c92890f3750
Add `file-system-ignore-case-p', use it.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3179
diff
changeset
|
285 (set-buffer (get-buffer pkg-outbuf)) ;; Probably already the current buffer. |
|
3c92890f3750
Add `file-system-ignore-case-p', use it.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3179
diff
changeset
|
286 (goto-char (point-min)) |
|
3c92890f3750
Add `file-system-ignore-case-p', use it.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3179
diff
changeset
|
287 (setq regexp (concat "\\bpkginfo" |
|
3c92890f3750
Add `file-system-ignore-case-p', use it.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3179
diff
changeset
|
288 (char-to-string directory-sep-char) |
|
3c92890f3750
Add `file-system-ignore-case-p', use it.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3179
diff
changeset
|
289 "MANIFEST\\...*")) |
| 428 | 290 |
|
4720
3c92890f3750
Add `file-system-ignore-case-p', use it.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3179
diff
changeset
|
291 ;; Look for the manifest. |
|
3c92890f3750
Add `file-system-ignore-case-p', use it.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3179
diff
changeset
|
292 (if (not (re-search-forward regexp nil t)) |
|
3c92890f3750
Add `file-system-ignore-case-p', use it.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3179
diff
changeset
|
293 (progn |
|
3c92890f3750
Add `file-system-ignore-case-p', use it.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3179
diff
changeset
|
294 ;; We didn't find a manifest. Make one. |
| 428 | 295 |
|
4720
3c92890f3750
Add `file-system-ignore-case-p', use it.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3179
diff
changeset
|
296 ;; Yuk. We weren't passed the package name, and so we have |
|
3c92890f3750
Add `file-system-ignore-case-p', use it.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3179
diff
changeset
|
297 ;; to dig for it. Look for it as the subdirectory name below |
|
3c92890f3750
Add `file-system-ignore-case-p', use it.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3179
diff
changeset
|
298 ;; "lisp", or "man". |
|
3c92890f3750
Add `file-system-ignore-case-p', use it.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3179
diff
changeset
|
299 ;; Here, we don't use a single regexp because we want to search |
|
3c92890f3750
Add `file-system-ignore-case-p', use it.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3179
diff
changeset
|
300 ;; the directories for a package name in a particular order. |
|
3c92890f3750
Add `file-system-ignore-case-p', use it.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3179
diff
changeset
|
301 (if (catch 'done |
|
3c92890f3750
Add `file-system-ignore-case-p', use it.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3179
diff
changeset
|
302 (let ((dirs '("lisp" "man")) |
|
3c92890f3750
Add `file-system-ignore-case-p', use it.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3179
diff
changeset
|
303 rexp) |
|
3c92890f3750
Add `file-system-ignore-case-p', use it.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3179
diff
changeset
|
304 (while dirs |
|
3c92890f3750
Add `file-system-ignore-case-p', use it.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3179
diff
changeset
|
305 (setq rexp (concat "\\b" (car dirs) |
|
3c92890f3750
Add `file-system-ignore-case-p', use it.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3179
diff
changeset
|
306 "[\\/]\\([^\\/]+\\)[\//]")) |
|
3c92890f3750
Add `file-system-ignore-case-p', use it.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3179
diff
changeset
|
307 (if (re-search-forward rexp nil t) |
|
3c92890f3750
Add `file-system-ignore-case-p', use it.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3179
diff
changeset
|
308 (throw 'done t)) |
|
3c92890f3750
Add `file-system-ignore-case-p', use it.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3179
diff
changeset
|
309 (setq dirs (cdr dirs))))) |
|
3c92890f3750
Add `file-system-ignore-case-p', use it.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3179
diff
changeset
|
310 (progn |
|
3c92890f3750
Add `file-system-ignore-case-p', use it.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3179
diff
changeset
|
311 (setq package-name (buffer-substring (match-beginning 1) |
|
3c92890f3750
Add `file-system-ignore-case-p', use it.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3179
diff
changeset
|
312 (match-end 1))) |
| 428 | 313 |
|
4720
3c92890f3750
Add `file-system-ignore-case-p', use it.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3179
diff
changeset
|
314 ;; Get and erase the manifest buffer |
|
3c92890f3750
Add `file-system-ignore-case-p', use it.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3179
diff
changeset
|
315 (setq manifest-buf (get-buffer-create manifest-buf)) |
|
3c92890f3750
Add `file-system-ignore-case-p', use it.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3179
diff
changeset
|
316 (buffer-disable-undo manifest-buf) |
|
3c92890f3750
Add `file-system-ignore-case-p', use it.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3179
diff
changeset
|
317 (erase-buffer manifest-buf) |
|
3c92890f3750
Add `file-system-ignore-case-p', use it.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3179
diff
changeset
|
318 |
|
3c92890f3750
Add `file-system-ignore-case-p', use it.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3179
diff
changeset
|
319 ;; Now, scan through the output buffer, looking for |
|
3c92890f3750
Add `file-system-ignore-case-p', use it.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3179
diff
changeset
|
320 ;; file and directory names. |
|
3c92890f3750
Add `file-system-ignore-case-p', use it.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3179
diff
changeset
|
321 (goto-char (point-min)) |
|
3c92890f3750
Add `file-system-ignore-case-p', use it.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3179
diff
changeset
|
322 ;; for each line ... |
|
3c92890f3750
Add `file-system-ignore-case-p', use it.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3179
diff
changeset
|
323 (while (< (point) (point-max)) |
|
3c92890f3750
Add `file-system-ignore-case-p', use it.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3179
diff
changeset
|
324 (beginning-of-line) |
|
3c92890f3750
Add `file-system-ignore-case-p', use it.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3179
diff
changeset
|
325 (setq pathname nil) |
| 428 | 326 |
|
4720
3c92890f3750
Add `file-system-ignore-case-p', use it.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3179
diff
changeset
|
327 ;; scan through the regexps, looking for a pathname |
|
3c92890f3750
Add `file-system-ignore-case-p', use it.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3179
diff
changeset
|
328 (if (catch 'found-path |
|
3c92890f3750
Add `file-system-ignore-case-p', use it.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3179
diff
changeset
|
329 (setq regexps package-admin-tar-filename-regexps) |
|
3c92890f3750
Add `file-system-ignore-case-p', use it.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3179
diff
changeset
|
330 (while regexps |
|
3c92890f3750
Add `file-system-ignore-case-p', use it.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3179
diff
changeset
|
331 (if (looking-at (car regexps)) |
|
3c92890f3750
Add `file-system-ignore-case-p', use it.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3179
diff
changeset
|
332 (progn |
|
3c92890f3750
Add `file-system-ignore-case-p', use it.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3179
diff
changeset
|
333 (setq pathname |
|
3c92890f3750
Add `file-system-ignore-case-p', use it.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3179
diff
changeset
|
334 (buffer-substring |
|
3c92890f3750
Add `file-system-ignore-case-p', use it.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3179
diff
changeset
|
335 (match-beginning 1) |
|
3c92890f3750
Add `file-system-ignore-case-p', use it.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3179
diff
changeset
|
336 (match-end 1))) |
|
3c92890f3750
Add `file-system-ignore-case-p', use it.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3179
diff
changeset
|
337 (throw 'found-path t))) |
|
3c92890f3750
Add `file-system-ignore-case-p', use it.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3179
diff
changeset
|
338 (setq regexps (cdr regexps)))) |
|
3c92890f3750
Add `file-system-ignore-case-p', use it.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3179
diff
changeset
|
339 (progn |
|
3c92890f3750
Add `file-system-ignore-case-p', use it.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3179
diff
changeset
|
340 ;; found a pathname -- add it to the manifest |
|
3c92890f3750
Add `file-system-ignore-case-p', use it.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3179
diff
changeset
|
341 ;; buffer |
|
3c92890f3750
Add `file-system-ignore-case-p', use it.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3179
diff
changeset
|
342 (save-excursion |
|
3c92890f3750
Add `file-system-ignore-case-p', use it.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3179
diff
changeset
|
343 (set-buffer manifest-buf) |
|
3c92890f3750
Add `file-system-ignore-case-p', use it.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3179
diff
changeset
|
344 (goto-char (point-max)) |
|
3c92890f3750
Add `file-system-ignore-case-p', use it.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3179
diff
changeset
|
345 (insert pathname "\n")))) |
|
3c92890f3750
Add `file-system-ignore-case-p', use it.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3179
diff
changeset
|
346 (forward-line 1)) |
| 428 | 347 |
|
4720
3c92890f3750
Add `file-system-ignore-case-p', use it.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3179
diff
changeset
|
348 ;; Processed all lines. |
|
3c92890f3750
Add `file-system-ignore-case-p', use it.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3179
diff
changeset
|
349 ;; Now, create the file, pkginfo/MANIFEST.<pkgname> |
| 428 | 350 |
|
4720
3c92890f3750
Add `file-system-ignore-case-p', use it.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3179
diff
changeset
|
351 ;; We use `expand-file-name' instead of `concat', |
|
3c92890f3750
Add `file-system-ignore-case-p', use it.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3179
diff
changeset
|
352 ;; for portability. |
|
3c92890f3750
Add `file-system-ignore-case-p', use it.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3179
diff
changeset
|
353 (setq pathname (expand-file-name "pkginfo" |
|
3c92890f3750
Add `file-system-ignore-case-p', use it.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3179
diff
changeset
|
354 pkg-topdir)) |
|
3c92890f3750
Add `file-system-ignore-case-p', use it.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3179
diff
changeset
|
355 ;; Create pkginfo, if necessary |
|
3c92890f3750
Add `file-system-ignore-case-p', use it.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3179
diff
changeset
|
356 (if (not (file-directory-p pathname)) |
|
3c92890f3750
Add `file-system-ignore-case-p', use it.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3179
diff
changeset
|
357 (make-directory pathname)) |
|
3c92890f3750
Add `file-system-ignore-case-p', use it.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3179
diff
changeset
|
358 (setq pathname (expand-file-name |
|
3c92890f3750
Add `file-system-ignore-case-p', use it.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3179
diff
changeset
|
359 (concat "MANIFEST." package-name) |
|
3c92890f3750
Add `file-system-ignore-case-p', use it.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3179
diff
changeset
|
360 pathname)) |
|
3c92890f3750
Add `file-system-ignore-case-p', use it.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3179
diff
changeset
|
361 (save-excursion |
|
3c92890f3750
Add `file-system-ignore-case-p', use it.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3179
diff
changeset
|
362 (set-buffer manifest-buf) |
|
3c92890f3750
Add `file-system-ignore-case-p', use it.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3179
diff
changeset
|
363 ;; Put the files in sorted order |
|
3c92890f3750
Add `file-system-ignore-case-p', use it.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3179
diff
changeset
|
364 (if-fboundp 'sort-lines |
|
3c92890f3750
Add `file-system-ignore-case-p', use it.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3179
diff
changeset
|
365 (sort-lines nil (point-min) (point-max)) |
|
3c92890f3750
Add `file-system-ignore-case-p', use it.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3179
diff
changeset
|
366 (warn "`xemacs-base' not installed, MANIFEST.%s not sorted" |
|
3c92890f3750
Add `file-system-ignore-case-p', use it.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3179
diff
changeset
|
367 package-name)) |
|
3c92890f3750
Add `file-system-ignore-case-p', use it.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3179
diff
changeset
|
368 ;; Write the file. |
|
3c92890f3750
Add `file-system-ignore-case-p', use it.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3179
diff
changeset
|
369 ;; Note that using `write-region' *BYPASSES* any check |
|
3c92890f3750
Add `file-system-ignore-case-p', use it.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3179
diff
changeset
|
370 ;; to see if XEmacs is currently editing/visiting the |
|
3c92890f3750
Add `file-system-ignore-case-p', use it.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3179
diff
changeset
|
371 ;; file. |
|
3c92890f3750
Add `file-system-ignore-case-p', use it.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3179
diff
changeset
|
372 (write-region (point-min) (point-max) pathname)) |
|
3c92890f3750
Add `file-system-ignore-case-p', use it.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3179
diff
changeset
|
373 (kill-buffer manifest-buf)))))))) |
| 428 | 374 |
| 375 ;;;###autoload | |
| 376 (defun package-admin-add-binary-package (file &optional pkg-dir) | |
| 377 "Install a pre-bytecompiled XEmacs package into package hierarchy." | |
| 378 (interactive "fPackage tarball: ") | |
| 379 (let ((buf (get-buffer-create package-admin-temp-buffer)) | |
| 380 (status 1) | |
| 1365 | 381 start err-list) |
| 428 | 382 (setq pkg-dir (package-admin-get-install-dir 'unknown pkg-dir)) |
| 383 ;; Ensure that the current directory doesn't change | |
| 384 (save-excursion | |
| 385 (set-buffer buf) | |
| 386 ;; This is not really needed | |
| 387 (setq default-directory (file-name-as-directory pkg-dir)) | |
| 388 (setq case-fold-search t) | |
| 389 (buffer-disable-undo) | |
| 390 (goto-char (setq start (point-max))) | |
| 391 (if (= 0 (setq status (funcall package-admin-install-function | |
| 392 file pkg-dir buf))) | |
| 393 (progn | |
| 394 ;; First, check for errors. | |
| 395 ;; We can't necessarily rely upon process error codes. | |
| 396 (catch 'done | |
| 397 (goto-char start) | |
| 398 (setq err-list package-admin-error-messages) | |
| 399 (while err-list | |
| 400 (if (re-search-forward (car err-list) nil t) | |
| 401 (progn | |
| 402 (setq status 1) | |
| 1365 | 403 (throw 'done nil))) |
| 404 (setq err-list (cdr err-list)))) | |
| 428 | 405 ;; Make sure that the MANIFEST file exists |
| 1365 | 406 (package-admin-check-manifest buf pkg-dir)))) |
| 407 status)) | |
| 428 | 408 |
| 409 (defun package-admin-rmtree (directory) | |
| 410 "Delete a directory and all of its contents, recursively. | |
| 411 This is a feeble attempt at making a portable rmdir." | |
| 412 (setq directory (file-name-as-directory directory)) | |
| 413 (let ((files (directory-files directory nil nil nil t)) | |
| 414 (dirs (directory-files directory nil nil nil 'dirs))) | |
| 415 (while dirs | |
| 416 (if (not (member (car dirs) '("." ".."))) | |
| 417 (let ((dir (expand-file-name (car dirs) directory))) | |
| 418 (condition-case err | |
| 419 (if (file-symlink-p dir) ;; just in case, handle symlinks | |
| 420 (delete-file dir) | |
| 421 (package-admin-rmtree dir)) | |
| 422 (file-error | |
| 423 (message "%s: %s: \"%s\"" (nth 1 err) (nth 2 err) (nth 3 err))))) | |
| 424 (setq dirs (cdr dirs)))) | |
| 425 (while files | |
| 426 (condition-case err | |
| 427 (delete-file (expand-file-name (car files) directory)) | |
| 428 (file-error | |
| 429 (message "%s: %s: \"%s\"" (nth 1 err) (nth 2 err) (nth 3 err)))) | |
| 430 (setq files (cdr files))) | |
| 431 (condition-case err | |
| 432 (delete-directory directory) | |
| 433 (file-error | |
| 434 (message "%s: %s: \"%s\"" (nth 1 err) (nth 2 err) (nth 3 err)))))) | |
| 435 | |
| 436 (defun package-admin-get-lispdir (pkg-topdir package) | |
| 437 (let (package-lispdir) | |
| 438 (if (and (setq package-lispdir (expand-file-name "lisp" pkg-topdir)) | |
| 439 (setq package-lispdir (expand-file-name (symbol-name package) | |
| 440 package-lispdir)) | |
| 441 (file-accessible-directory-p package-lispdir)) | |
| 1365 | 442 package-lispdir))) |
| 428 | 443 |
| 444 (defun package-admin-delete-binary-package (package pkg-topdir) | |
| 445 "Delete a binary installation of PACKAGE below directory PKG-TOPDIR. | |
| 446 PACKAGE is a symbol, not a string." | |
| 1365 | 447 (let (manifest-file package-lispdir dirs file) |
| 428 | 448 (setq pkg-topdir (package-admin-get-install-dir package pkg-topdir)) |
| 449 (setq manifest-file (package-admin-get-manifest-file pkg-topdir package)) | |
| 628 | 450 (run-hook-with-args 'package-delete-hook package pkg-topdir) |
| 428 | 451 (if (file-exists-p manifest-file) |
| 452 (progn | |
| 453 ;; The manifest file exists! Use it to delete the old distribution. | |
| 454 (message "Removing old files for package \"%s\" ..." package) | |
| 455 (sit-for 0) | |
| 1365 | 456 (with-temp-buffer |
| 428 | 457 (buffer-disable-undo) |
| 458 (erase-buffer) | |
| 459 (insert-file-contents manifest-file) | |
| 460 (goto-char (point-min)) | |
| 461 | |
| 462 ;; For each entry in the MANIFEST ... | |
| 463 (while (< (point) (point-max)) | |
| 464 (beginning-of-line) | |
| 465 (setq file (expand-file-name (buffer-substring | |
| 466 (point) | |
| 467 (point-at-eol)) | |
| 468 pkg-topdir)) | |
| 469 (if (file-directory-p file) | |
| 470 ;; Keep a record of each directory | |
| 471 (setq dirs (cons file dirs)) | |
| 472 ;; Delete each file. | |
| 473 ;; Make sure that the file is writable. | |
| 474 ;; (This is important under MS Windows.) | |
| 475 ;; I do not know why it important under MS Windows but | |
| 629 | 476 ;; 1. It bombs out when the file does not exist. This can be condition-cased |
| 428 | 477 ;; 2. If I removed the write permissions, I do not want XEmacs to just ignore them. |
| 478 ;; If it wants to, XEmacs may ask, but that is about all | |
| 479 ;; (set-file-modes file 438) ;; 438 -> #o666 | |
| 480 ;; Note, user might have removed the file! | |
| 481 (condition-case () | |
| 482 (delete-file file) | |
| 444 | 483 (error nil))) ;; We may want to turn the error into a Warning? |
| 428 | 484 (forward-line 1)) |
| 444 | 485 |
| 428 | 486 ;; Delete empty directories. |
| 487 (if dirs | |
| 1365 | 488 (progn |
| 489 (mapc | |
| 490 (lambda (dir) | |
| 491 (condition-case () | |
| 492 (delete-directory dir))) | |
| 493 dirs))) | |
| 428 | 494 ;; Delete the MANIFEST file |
| 495 ;; (set-file-modes manifest-file 438) ;; 438 -> #o666 | |
| 496 ;; Note. Packages can have MANIFEST in MANIFEST. | |
| 497 (condition-case () | |
| 498 (delete-file manifest-file) | |
| 499 (error nil)) ;; Do warning? | |
| 1365 | 500 (message "Removing old files for package \"%s\" ... done" package))) |
| 501 ;; The manifest file doesn't exist. Fallback to just deleting the | |
| 502 ;; package-specific lisp directory, if it exists. | |
| 503 ;; | |
| 504 ;; Delete old lisp directory, if any | |
| 505 ;; Gads, this is ugly. However, we're not supposed to use `concat' | |
| 506 ;; in the name of portability. | |
| 507 (setq package-lispdir (package-admin-get-lispdir pkg-topdir package)) | |
| 1378 | 508 (when package-lispdir |
| 509 (message "Removing old lisp directory \"%s\" ..." package-lispdir) | |
| 510 (sit-for 0) | |
| 511 (package-admin-rmtree package-lispdir) | |
| 512 (message "Removing old lisp directory \"%s\" ... done" package-lispdir))) | |
| 428 | 513 ;; Delete the package from the database of installed packages. |
| 514 (package-delete-name package))) | |
| 515 | |
| 516 (provide 'package-admin) | |
| 517 | |
| 518 ;;; package-admin.el ends here |