[Top][All Lists]
[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[commit-womb] addressbook COPYING ChangeLog Makefile README a...
|
From: |
Jose E. Marchesi |
|
Subject: |
[commit-womb] addressbook COPYING ChangeLog Makefile README a... |
|
Date: |
Thu, 23 Aug 2007 20:20:54 +0000 |
CVSROOT: /cvsroot/womb
Module name: addressbook
Changes by: Jose E. Marchesi <jemarch> 07/08/23 20:20:54
Removed files:
. : COPYING ChangeLog Makefile README
addressbook.el addressbook.texi uuid.el
vcard.el
Log message:
CVSWeb URLs:
http://cvs.savannah.gnu.org/viewcvs/addressbook/COPYING?cvsroot=womb&r1=1.1&r2=0
http://cvs.savannah.gnu.org/viewcvs/addressbook/ChangeLog?cvsroot=womb&r1=1.29&r2=0
http://cvs.savannah.gnu.org/viewcvs/addressbook/Makefile?cvsroot=womb&r1=1.3&r2=0
http://cvs.savannah.gnu.org/viewcvs/addressbook/README?cvsroot=womb&r1=1.2&r2=0
http://cvs.savannah.gnu.org/viewcvs/addressbook/addressbook.el?cvsroot=womb&r1=1.31&r2=0
http://cvs.savannah.gnu.org/viewcvs/addressbook/addressbook.texi?cvsroot=womb&r1=1.1.1.1&r2=0
http://cvs.savannah.gnu.org/viewcvs/addressbook/uuid.el?cvsroot=womb&r1=1.1&r2=0
http://cvs.savannah.gnu.org/viewcvs/addressbook/vcard.el?cvsroot=womb&r1=1.3&r2=0
Patches:
Index: COPYING
===================================================================
RCS file: COPYING
diff -N COPYING
--- COPYING 31 May 2007 14:07:36 -0000 1.1
+++ /dev/null 1 Jan 1970 00:00:00 -0000
@@ -1,339 +0,0 @@
- GNU GENERAL PUBLIC LICENSE
- Version 2, June 1991
-
- Copyright (C) 1989, 1991 Free Software Foundation, Inc.,
- 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
- Everyone is permitted to copy and distribute verbatim copies
- of this license document, but changing it is not allowed.
-
- Preamble
-
- The licenses for most software are designed to take away your
-freedom to share and change it. By contrast, the GNU General Public
-License is intended to guarantee your freedom to share and change free
-software--to make sure the software is free for all its users. This
-General Public License applies to most of the Free Software
-Foundation's software and to any other program whose authors commit to
-using it. (Some other Free Software Foundation software is covered by
-the GNU Lesser General Public License instead.) You can apply it to
-your programs, too.
-
- When we speak of free software, we are referring to freedom, not
-price. Our General Public Licenses are designed to make sure that you
-have the freedom to distribute copies of free software (and charge for
-this service if you wish), that you receive source code or can get it
-if you want it, that you can change the software or use pieces of it
-in new free programs; and that you know you can do these things.
-
- To protect your rights, we need to make restrictions that forbid
-anyone to deny you these rights or to ask you to surrender the rights.
-These restrictions translate to certain responsibilities for you if you
-distribute copies of the software, or if you modify it.
-
- For example, if you distribute copies of such a program, whether
-gratis or for a fee, you must give the recipients all the rights that
-you have. You must make sure that they, too, receive or can get the
-source code. And you must show them these terms so they know their
-rights.
-
- We protect your rights with two steps: (1) copyright the software, and
-(2) offer you this license which gives you legal permission to copy,
-distribute and/or modify the software.
-
- Also, for each author's protection and ours, we want to make certain
-that everyone understands that there is no warranty for this free
-software. If the software is modified by someone else and passed on, we
-want its recipients to know that what they have is not the original, so
-that any problems introduced by others will not reflect on the original
-authors' reputations.
-
- Finally, any free program is threatened constantly by software
-patents. We wish to avoid the danger that redistributors of a free
-program will individually obtain patent licenses, in effect making the
-program proprietary. To prevent this, we have made it clear that any
-patent must be licensed for everyone's free use or not licensed at all.
-
- The precise terms and conditions for copying, distribution and
-modification follow.
-
- GNU GENERAL PUBLIC LICENSE
- TERMS AND CONDITIONS FOR COPYING, DISTRIBUTION AND MODIFICATION
-
- 0. This License applies to any program or other work which contains
-a notice placed by the copyright holder saying it may be distributed
-under the terms of this General Public License. The "Program", below,
-refers to any such program or work, and a "work based on the Program"
-means either the Program or any derivative work under copyright law:
-that is to say, a work containing the Program or a portion of it,
-either verbatim or with modifications and/or translated into another
-language. (Hereinafter, translation is included without limitation in
-the term "modification".) Each licensee is addressed as "you".
-
-Activities other than copying, distribution and modification are not
-covered by this License; they are outside its scope. The act of
-running the Program is not restricted, and the output from the Program
-is covered only if its contents constitute a work based on the
-Program (independent of having been made by running the Program).
-Whether that is true depends on what the Program does.
-
- 1. You may copy and distribute verbatim copies of the Program's
-source code as you receive it, in any medium, provided that you
-conspicuously and appropriately publish on each copy an appropriate
-copyright notice and disclaimer of warranty; keep intact all the
-notices that refer to this License and to the absence of any warranty;
-and give any other recipients of the Program a copy of this License
-along with the Program.
-
-You may charge a fee for the physical act of transferring a copy, and
-you may at your option offer warranty protection in exchange for a fee.
-
- 2. You may modify your copy or copies of the Program or any portion
-of it, thus forming a work based on the Program, and copy and
-distribute such modifications or work under the terms of Section 1
-above, provided that you also meet all of these conditions:
-
- a) You must cause the modified files to carry prominent notices
- stating that you changed the files and the date of any change.
-
- b) You must cause any work that you distribute or publish, that in
- whole or in part contains or is derived from the Program or any
- part thereof, to be licensed as a whole at no charge to all third
- parties under the terms of this License.
-
- c) If the modified program normally reads commands interactively
- when run, you must cause it, when started running for such
- interactive use in the most ordinary way, to print or display an
- announcement including an appropriate copyright notice and a
- notice that there is no warranty (or else, saying that you provide
- a warranty) and that users may redistribute the program under
- these conditions, and telling the user how to view a copy of this
- License. (Exception: if the Program itself is interactive but
- does not normally print such an announcement, your work based on
- the Program is not required to print an announcement.)
-
-These requirements apply to the modified work as a whole. If
-identifiable sections of that work are not derived from the Program,
-and can be reasonably considered independent and separate works in
-themselves, then this License, and its terms, do not apply to those
-sections when you distribute them as separate works. But when you
-distribute the same sections as part of a whole which is a work based
-on the Program, the distribution of the whole must be on the terms of
-this License, whose permissions for other licensees extend to the
-entire whole, and thus to each and every part regardless of who wrote it.
-
-Thus, it is not the intent of this section to claim rights or contest
-your rights to work written entirely by you; rather, the intent is to
-exercise the right to control the distribution of derivative or
-collective works based on the Program.
-
-In addition, mere aggregation of another work not based on the Program
-with the Program (or with a work based on the Program) on a volume of
-a storage or distribution medium does not bring the other work under
-the scope of this License.
-
- 3. You may copy and distribute the Program (or a work based on it,
-under Section 2) in object code or executable form under the terms of
-Sections 1 and 2 above provided that you also do one of the following:
-
- a) Accompany it with the complete corresponding machine-readable
- source code, which must be distributed under the terms of Sections
- 1 and 2 above on a medium customarily used for software interchange; or,
-
- b) Accompany it with a written offer, valid for at least three
- years, to give any third party, for a charge no more than your
- cost of physically performing source distribution, a complete
- machine-readable copy of the corresponding source code, to be
- distributed under the terms of Sections 1 and 2 above on a medium
- customarily used for software interchange; or,
-
- c) Accompany it with the information you received as to the offer
- to distribute corresponding source code. (This alternative is
- allowed only for noncommercial distribution and only if you
- received the program in object code or executable form with such
- an offer, in accord with Subsection b above.)
-
-The source code for a work means the preferred form of the work for
-making modifications to it. For an executable work, complete source
-code means all the source code for all modules it contains, plus any
-associated interface definition files, plus the scripts used to
-control compilation and installation of the executable. However, as a
-special exception, the source code distributed need not include
-anything that is normally distributed (in either source or binary
-form) with the major components (compiler, kernel, and so on) of the
-operating system on which the executable runs, unless that component
-itself accompanies the executable.
-
-If distribution of executable or object code is made by offering
-access to copy from a designated place, then offering equivalent
-access to copy the source code from the same place counts as
-distribution of the source code, even though third parties are not
-compelled to copy the source along with the object code.
-
- 4. You may not copy, modify, sublicense, or distribute the Program
-except as expressly provided under this License. Any attempt
-otherwise to copy, modify, sublicense or distribute the Program is
-void, and will automatically terminate your rights under this License.
-However, parties who have received copies, or rights, from you under
-this License will not have their licenses terminated so long as such
-parties remain in full compliance.
-
- 5. You are not required to accept this License, since you have not
-signed it. However, nothing else grants you permission to modify or
-distribute the Program or its derivative works. These actions are
-prohibited by law if you do not accept this License. Therefore, by
-modifying or distributing the Program (or any work based on the
-Program), you indicate your acceptance of this License to do so, and
-all its terms and conditions for copying, distributing or modifying
-the Program or works based on it.
-
- 6. Each time you redistribute the Program (or any work based on the
-Program), the recipient automatically receives a license from the
-original licensor to copy, distribute or modify the Program subject to
-these terms and conditions. You may not impose any further
-restrictions on the recipients' exercise of the rights granted herein.
-You are not responsible for enforcing compliance by third parties to
-this License.
-
- 7. If, as a consequence of a court judgment or allegation of patent
-infringement or for any other reason (not limited to patent issues),
-conditions are imposed on you (whether by court order, agreement or
-otherwise) that contradict the conditions of this License, they do not
-excuse you from the conditions of this License. If you cannot
-distribute so as to satisfy simultaneously your obligations under this
-License and any other pertinent obligations, then as a consequence you
-may not distribute the Program at all. For example, if a patent
-license would not permit royalty-free redistribution of the Program by
-all those who receive copies directly or indirectly through you, then
-the only way you could satisfy both it and this License would be to
-refrain entirely from distribution of the Program.
-
-If any portion of this section is held invalid or unenforceable under
-any particular circumstance, the balance of the section is intended to
-apply and the section as a whole is intended to apply in other
-circumstances.
-
-It is not the purpose of this section to induce you to infringe any
-patents or other property right claims or to contest validity of any
-such claims; this section has the sole purpose of protecting the
-integrity of the free software distribution system, which is
-implemented by public license practices. Many people have made
-generous contributions to the wide range of software distributed
-through that system in reliance on consistent application of that
-system; it is up to the author/donor to decide if he or she is willing
-to distribute software through any other system and a licensee cannot
-impose that choice.
-
-This section is intended to make thoroughly clear what is believed to
-be a consequence of the rest of this License.
-
- 8. If the distribution and/or use of the Program is restricted in
-certain countries either by patents or by copyrighted interfaces, the
-original copyright holder who places the Program under this License
-may add an explicit geographical distribution limitation excluding
-those countries, so that distribution is permitted only in or among
-countries not thus excluded. In such case, this License incorporates
-the limitation as if written in the body of this License.
-
- 9. The Free Software Foundation may publish revised and/or new versions
-of the General Public License from time to time. Such new versions will
-be similar in spirit to the present version, but may differ in detail to
-address new problems or concerns.
-
-Each version is given a distinguishing version number. If the Program
-specifies a version number of this License which applies to it and "any
-later version", you have the option of following the terms and conditions
-either of that version or of any later version published by the Free
-Software Foundation. If the Program does not specify a version number of
-this License, you may choose any version ever published by the Free Software
-Foundation.
-
- 10. If you wish to incorporate parts of the Program into other free
-programs whose distribution conditions are different, write to the author
-to ask for permission. For software which is copyrighted by the Free
-Software Foundation, write to the Free Software Foundation; we sometimes
-make exceptions for this. Our decision will be guided by the two goals
-of preserving the free status of all derivatives of our free software and
-of promoting the sharing and reuse of software generally.
-
- NO WARRANTY
-
- 11. BECAUSE THE PROGRAM IS LICENSED FREE OF CHARGE, THERE IS NO WARRANTY
-FOR THE PROGRAM, TO THE EXTENT PERMITTED BY APPLICABLE LAW. EXCEPT WHEN
-OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR OTHER PARTIES
-PROVIDE THE PROGRAM "AS IS" WITHOUT WARRANTY OF ANY KIND, EITHER EXPRESSED
-OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF
-MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE. THE ENTIRE RISK AS
-TO THE QUALITY AND PERFORMANCE OF THE PROGRAM IS WITH YOU. SHOULD THE
-PROGRAM PROVE DEFECTIVE, YOU ASSUME THE COST OF ALL NECESSARY SERVICING,
-REPAIR OR CORRECTION.
-
- 12. IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING
-WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY AND/OR
-REDISTRIBUTE THE PROGRAM AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES,
-INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING
-OUT OF THE USE OR INABILITY TO USE THE PROGRAM (INCLUDING BUT NOT LIMITED
-TO LOSS OF DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY
-YOU OR THIRD PARTIES OR A FAILURE OF THE PROGRAM TO OPERATE WITH ANY OTHER
-PROGRAMS), EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE
-POSSIBILITY OF SUCH DAMAGES.
-
- END OF TERMS AND CONDITIONS
-
- How to Apply These Terms to Your New Programs
-
- If you develop a new program, and you want it to be of the greatest
-possible use to the public, the best way to achieve this is to make it
-free software which everyone can redistribute and change under these terms.
-
- To do so, attach the following notices to the program. It is safest
-to attach them to the start of each source file to most effectively
-convey the exclusion of warranty; and each file should have at least
-the "copyright" line and a pointer to where the full notice is found.
-
- <one line to give the program's name and a brief idea of what it does.>
- Copyright (C) <year> <name of author>
-
- This program is free software; you can redistribute it and/or modify
- it under the terms of the GNU General Public License as published by
- the Free Software Foundation; either version 2 of the License, or
- (at your option) any later version.
-
- This program is distributed in the hope that it will be useful,
- but WITHOUT ANY WARRANTY; without even the implied warranty of
- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- GNU General Public License for more details.
-
- You should have received a copy of the GNU General Public License along
- with this program; if not, write to the Free Software Foundation, Inc.,
- 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
-
-Also add information on how to contact you by electronic and paper mail.
-
-If the program is interactive, make it output a short notice like this
-when it starts in an interactive mode:
-
- Gnomovision version 69, Copyright (C) year name of author
- Gnomovision comes with ABSOLUTELY NO WARRANTY; for details type `show w'.
- This is free software, and you are welcome to redistribute it
- under certain conditions; type `show c' for details.
-
-The hypothetical commands `show w' and `show c' should show the appropriate
-parts of the General Public License. Of course, the commands you use may
-be called something other than `show w' and `show c'; they could even be
-mouse-clicks or menu items--whatever suits your program.
-
-You should also get your employer (if you work as a programmer) or your
-school, if any, to sign a "copyright disclaimer" for the program, if
-necessary. Here is a sample; alter the names:
-
- Yoyodyne, Inc., hereby disclaims all copyright interest in the program
- `Gnomovision' (which makes passes at compilers) written by James Hacker.
-
- <signature of Ty Coon>, 1 April 1989
- Ty Coon, President of Vice
-
-This General Public License does not permit incorporating your program into
-proprietary programs. If your program is a subroutine library, you may
-consider it more useful to permit linking proprietary applications with the
-library. If this is what you want to do, use the GNU Lesser General
-Public License instead of this License.
Index: ChangeLog
===================================================================
RCS file: ChangeLog
diff -N ChangeLog
--- ChangeLog 31 May 2007 14:06:50 -0000 1.29
+++ /dev/null 1 Jan 1970 00:00:00 -0000
@@ -1,186 +0,0 @@
-2007-05-31 Jose E. Marchesi <address@hidden>
-
- * vcard.el: FSF address updated in copyright notice.
-
- * COPYING: New file.
-
-2007-05-30 Jose E. Marchesi <address@hidden>
-
- * uuid.el: New file.
- (uuid): New group.
- (uuid-ifconfig-program): New custom.
- (uuid-hexoctect-regexp): New variable.
- (uuid-time-low-regexp): New variable.
- (uuid-time-mid-regexp): New variable.
- (uuid-version-and-time-high-regexp): New variable.
- (uuid-variant-and-clock-seqhigh-regexp): New variable.
- (uuid-clock-seq-low-regexp): New variable.
- (uuid-node-regexp): New variable.
- (uuid-regexp): New variable.
- (uuid-time-based-version-hex): New variable.
- (uuid-dce-security-version-hex): New variable.
- (uuid-name-based-md5-version-hex): New variable.
- (uuid-name-based-sha1-version-hex): New variable.
- (uuid-random-number-based-version-hex): New variable.
- (uuid-namespace-dns): New variable.
- (uuid-namespace-url): New variable.
- (uuid-namespace-oid): New variable.
- (uuid-namespace-x500): New variable.
- (uuid-generate): New function.
- (uuid-generate-name-based): New function.
- (uuid-generate-random-based): New function.
- (uuid-generate-time-based): New function.
- (uuid-generate-time): New function.
- (uuid-generate-clock-sequence): New function.
- (uuid-format-mac-address): New function.
- (uuid-get-mac-address): New function.
- (uuid-namespace-to-string): New function.
- (uuidp): New function.
- (uuid-lessp): New function.
- (uuid-equal): New function.
-
-2007-05-27 Xavier Maillard <address@hidden>
-
- * addressbook.el (addrbook-summary-mode): Bind <up> and <down> to
- respectively previous and next contact. Bind 'a' to contact creation.
-
-2007-05-15 Jose E. Marchesi <address@hidden>
-
- * addressbook.el (addrbook-backend): New customize.
- (addrbook-directory): New customize.
- (addrbook-be-read-cards): New function.
- (addrbook-be-write-card): New function.
- (addrbook-be-delete-card): New function.
-
-2007-05-10 Xavier Maillard <address@hidden>
-
- * addressbook.el (addrbook-contact-display-attribute-photo-logo):
- Introduce url package again so that we can fetch local or remote
- image. Only require url when we are sure we need it and use
- string-as-unibyte to get data.
- (addrbook): Added :link property
-
-2007-05-09 Jose E. Marchesi <address@hidden>
-
- * addressbook.el: outline-mode like headlines
-
-2007-05-08 Xavier Maillard <address@hidden>
-
- * vcard.el (vcard-parse-file): New helper function used in
addrbook-import-vcard.
-
- * addressbook.el (addrbook-bury): New function.
- (addrbook-summary-mode, addrbook-contact-mode): Bind b key to
- addrbook-bury.
- (addrbook-write-data-1): New function. Take one VCARD and write
- its data in a FILE.
- (addrbook-import-vcard, addrbook-export-vcard): New functions. Use
- it. Import and Export VCARDs from addrbook-summary buffer.
- (addrbook-summary-mode): Bind i and x to import/export.
- (addrbook-contact-display-attribute-photo-logo): Dropped misuse of
- the url package and replace it with simpler functions. No longer
- require url package.
-
- * Makefile: Completely rewritten to follow standards. Added
- several new target to build and to install the manual.
- Added license header and CVS tag.
-
-2007-05-08 Jose E. Marchesi <address@hidden>
-
- * addressbook.el (addrbook-summary-display): expand line to
- frame-width. Do not fill with blanks. Append a extra newline to
- the buffer in order to let the line highlight overlay trick to
- work in the last entry.
- (addrbook-summary-goto-contact): Make the contact buffer writable
- before card displaying. Trick to expand the overlay to the entire
- line without filling with blanks.
- (addrbook-summary): Remove call to `addrbook-open'.
- (addrbook-summary-show-contact): Make the contact buffer read only.
- (addrbook-contact-delete-attribute): renamed from
- `addrbook-contact-delete-attribute-type'
- (addrbook-contact-mode): Use `addrbook-contact-delete-attribute'.
- (addressbook): Show summary when the buffer exists.
- (addrbook-multiple-frames-p): New custom variable.
- (addrbook-show-contact): Take care about `addrbook-multiple-frames-p'.
- (addrbook-show-summary): idem.
- (addrbook-ask-for-search): Changed default to nil.
-
-2007-05-07 Xavier Maillard <address@hidden>
-
- * Makefile: New file.
-
-2007-05-07 Jose E. Marchesi <address@hidden>
-
- * addressbook.el (addrbook-summary-mode): Added mailer function to
- the summary.
- Sources reestructured.
- (addrbook-summary-display): renamed from `addrbook-summary-redisplay'
- (addrbook-quit): Fixed.
- (addrbook-get-prop-index): New function.
-
-2007-05-06 Jose E. Marchesi <address@hidden>
-
- * addressbook.el: `addrbook-custom-properties' removed.
- (addrbook-build-custom-property-group): New function.
- (addrbook-set-custom-properties): New function.
- (addrbook-set-custom-properties): Added doc string.
- (addrbook-ask-for-search): New customizable variable.
- (addrbook-attr-matches-p): New function.
- (addrbook-search-cards): New function.
- (addressbook-summary): Made non-interactive.
- (addrbook-summary-get-current-card): New function.
- (addrbook-summary-next-card): New function.
- (addrbook-summary-previous-card): New function.
- (addrbook-contact): New function.
-
-2007-05-05 Xavier Maillard <address@hidden>
-
- * addressbook.el: Do not require 'cl at run-time.
- (addrbook-mode-line-string, addrbook-summary-mode-line-string):
- New variables. Use them in *-set-mode-line (still needs attention).
- (addressbook-summary): Fixed autoload cookie.
-
-2007-05-05 Jose E. Marchesi <address@hidden>
-
- * addressbook.el (addrbook-open): New function.
- (addressbook): Use `addrbook-open'.
-
- * README: Added urls to web resources
-
- * addressbook.el (addrbook-get-prop-fields): use
- `addrbook-get-prop-fields'
- (addrbook-get-prop-parameters): simplified
- (addrbook-property-in-group-p): simplified
- (addrbook-get-prop-default-type): simplified
- (addrbook-value-empty-p): simplified
- (addrbook-number-of-values): simplified
- (addrbook-get-card-fn): simplified
- (addrbook-attribute-nodisplay): simplified
- (addrbook-display-attribute-photo-logo): simplified
- (addrbook-display-attribute-type): simplified
- (addrbook-group-hidden-p): simplified
- (addrbook-hide-show-group): simplified
- (addrbook-get-current-group): simplified
- (addrbook-get-text-property-line): simplified
- (addrbook-redisplay-group): simplified
- (addrbook-group-in-display-p): simplified
- (addrbook-read-cards): simplified
- (addrbook-add-attribute-type): simplified
- (addrbook-remove-attribute-type): simplified
- (addrbook-delete-card): simplified
- (addrbook-add-attribute): simplified
- (addrbook-next-card): simplified
- (addrbook-previous-card): simplified
- (addrbook-quit): simplified
- (addrbook-goto-next-group): simplified
- (addrbook-toggle-hide-show-group): simplified
- (addrbook-hide-all-groups): simplified
- (addrbook-show-all-groups): simplified
- (addrbook-cycle-groups): simplified
- (addrbook-fast-selection): simplified
- (addrbook-select-group): simplified
- (addrbook-select-property): simplified
- (addrbook-select-field): simplified
- (addressbook): simplified
-
- * New ChangeLog
-
Index: Makefile
===================================================================
RCS file: Makefile
diff -N Makefile
--- Makefile 8 May 2007 10:05:09 -0000 1.3
+++ /dev/null 1 Jan 1970 00:00:00 -0000
@@ -1,74 +0,0 @@
-# Copyright (C) 2007 Xavier Maillard <address@hidden>
-# Jose E. Marchesi <address@hidden>
-
-# This file is NOT part of GNU Emacs.
-
-# GNU Emacs is free software; you can redistribute it and/or modify
-# it under the terms of the GNU General Public License as published by
-# the Free Software Foundation; either version 2, or (at your option)
-# any later version.
-
-# GNU Emacs is distributed in the hope that it will be useful,
-# but WITHOUT ANY WARRANTY; without even the implied warranty of
-# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-# GNU General Public License for more details.
-
-# You should have received a copy of the GNU General Public License
-# along with GNU Emacs; see the file COPYING. If not, write to
-# the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
-# Boston, MA 02110-1301, USA.
-
-# $Id: Makefile,v 1.3 2007/05/08 10:05:09 zeDek Exp $
-
-# make install
-# make all
-# make clean
-
-EMACS = emacs
-SITEFLAG=--no-site-file
-GZIP=gzip
-
-SOURCE=$(wildcard *.el)
-TARGET=$(patsubst %.el,%.elc,$(SOURCE))
-COMPILED=$(wildcard *.elc)
-
-DESTDIR=
-PREFIX=$(DESTDIR)/usr/local
-INFODIR=$(PREFIX)/info
-MAN1DIR=$(PREFIX)/share/man/man1
-SITELISP=$(PREFIX)/share/emacs/site-lisp/addressbook
-
-INFODIR=$(PREFIX)/info
-
-INSTALLINFO = /usr/sbin/install-info --info-dir=$(INFODIR)
-
-.PHONY: all install clean
-.PRECIOUS: %.elc %.info %.html
-
-all: $(TARGET) addressbook.info
-
-install:
- test -d $(SITELISP) || mkdir -p $(SITELISP)
- [ -d $(INFODIR) ] || install -d $(INFODIR)
- install -m 644 $(SOURCE) $(SITELISP)
- install -m 644 $(COMPILED) $(SITELISP)
- install -m 0644 addressbook.info $(INFODIR)/addressbook
- $(INSTALLINFO) addressbook.info
-
-%.elc: %.el
- @echo "Byte compiling the source file "$<
- @$(EMACS) -batch -q \
- --eval '(setq load-path (cons "." load-path))' \
- -f batch-byte-compile $<
-
-%.info: %.texi
- makeinfo --no-split $<
-
-%.html: %.texi
- makeinfo --html --no-split $<
-
-remove-info:
- $(INSTALLINFO) --remove addressbook.info
-
-clean:
- -rm -f *~ $(COMPILED) addressbook.info addressbook.html
Index: README
===================================================================
RCS file: README
diff -N README
--- README 5 May 2007 02:39:54 -0000 1.2
+++ /dev/null 1 Jan 1970 00:00:00 -0000
@@ -1,19 +0,0 @@
--*- mode:text -*- Time-stamp: "07/05/05 04:32:44 jemarch"
-
-README for AddressBook
-======================
-
-AddresBook is a implementation of an addressbook for Emacs that makes
-use of the vCard standard to store contact information.
-
-The homepage of the addressbook is hosted in the Emacs Wiki:
-
- http://www.emacswiki.org/cgi-bin/wiki/AddressBook
-
-Development resources are currently hosted in the GNU Womb:
-
- http://savannah.gnu.org/projects/womb
-
-
-Send bug reports and suggestions to address@hidden
-
Index: addressbook.el
===================================================================
RCS file: addressbook.el
diff -N addressbook.el
--- addressbook.el 29 May 2007 23:11:41 -0000 1.31
+++ /dev/null 1 Jan 1970 00:00:00 -0000
@@ -1,2278 +0,0 @@
-;;;; addressbook.el --- A simple addressbook
-
-;; Copyright (C) 2007 Jose E. Marchesi
-
-;; Maintainer: Jose E. Marchesi
-;; Keywords: contacts, applications
-
-;; $Id: addressbook.el,v 1.31 2007/05/29 23:11:41 jemarch Exp $
-
-;; This file is NOT part of GNU Emacs.
-
-;; This program is free software; you can redistribute it and/or modify
-;; it under the terms of the GNU General Public License as published by
-;; the Free Software Foundation; either version 2, or (at your option)
-;; any later version.
-
-;; This program is distributed in the hope that it will be useful,
-;; but WITHOUT ANY WARRANTY; without even the implied warranty of
-;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-;; GNU General Public License for more details.
-
-;; You should have received a copy of the GNU General Public License
-;; along with this program; see the file COPYING. If not, write to the
-;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
-;; Boston, MA 02110-1301, USA.
-
-;;;; Commentary:
-
-;; A simple vCard based addressbook for Emacs
-;;
-;; File Contents
-;; =============
-;;
-;; * Constants
-;; * Customization
-;; * Variables
-;;
-;; * Properties management functions
-;;
-;; ** Groups
-;; ** Properties
-;; ** Cards
-;; ** Attributes
-;;
-;; * Addressbook contact editor
-;;
-;; ** Constants
-;; ** Variables
-;; ** Contact buffer management
-;; ** Display functions
-;; ** Modeline management
-;; ** Commands
-;; ** Major mode
-;;
-;; * Addressbook summary
-;;
-;; ** Constants
-;; ** Variables
-;; ** Summary buffer management
-;; ** Display functions
-;; ** Commands
-;; ** Modeline management
-;; ** Major mode
-;;
-;; * General commands (usable from all addressbook modes)
-;; * Backend management
-;;
-;; ** Customization and Variables
-;; ** Utility functions
-;; ** API
-;; ** Simple backend
-;; ** Multiple backend
-;;
-;; * Utility functions
-;;
-;; ** Fast selection
-;; ** Search functions
-;;
-;; * Entry points to the addressbook
-
-;;; Code:
-
-(eval-when-compile (require 'cl))
-(require 'vcard)
-(require 'mm-decode)
-
-;;;; * Constants
-
-(defconst addrbook-version "0.1"
- "Version of the addressbook")
-
-;;;; * Customization
-
-(defgroup addrbook nil
- "Addressbook subsytem"
- :group 'applications
- :link '(url-link "http://www.emacswiki.org/cgi-bin/wiki/AddressBook";))
-
-(defgroup addrbook-hooks nil
- "Addressbook hooks"
- :group 'addrbook)
-
-(defcustom addrbook-directory "~/.contacts"
- "Directory with stored vCards"
- :type 'directory
- :group 'addrbook)
-
-(defcustom addrbook-display-images t
- "Display images in the addressbook"
- :type 'boolean
- :group 'addrbook)
-
-(defcustom addrbook-display-groups
- '(identification-properties)
- "Groups to expand by default"
- :type 'sexp
- :group 'addrbook)
-
-(defcustom addrbook-force-addressbook-creation
- t
- "Force the creation of the addressbook file if it doesnt exist upon startup"
- :type 'boolean
- :group 'addrbook)
-
-(defcustom addrbook-attribute-indentation
- 1
- "Indentation deep for attribute titles"
- :type 'integer
- :group 'addrbook)
-
-(defcustom addrbook-field-indentation
- 2
- "Indentation deep for attribute fields"
- :type 'integer
- :group 'addrbook)
-
-(defcustom addrbook-ask-for-search
- nil
- "Whether the addressbook should ask for a search upon `addressbook'
invocation"
- :type 'boolean
- :group 'addrbook)
-
-(defcustom addrbook-field-for-sort
- "First name"
- "Field to use when sorting contacts.
-
-It may be \"Surname\", \"First Name\", \"AKA\", \"Name prefix\" or \"Name
suffix\"."
- :type 'string
- :group 'addrbook)
-
-(defcustom addrbook-use-multiple-frames
- nil
- "If t, open new frames when switching summary<->contact"
- :type 'boolean
- :group 'addrbook)
-
-(defface addrbook-summary-card-number
- '((((min-colors 88) (class color) (background light))
- :foreground "red1")
- (((class color) (background light))
- :foreground "red")
- (((min-colors 88) (class color) (background dark))
- :foreground "blue")
- (((class color) (background dark))
- :foreground "blue")
- (t
- :weight bold))
- "Face for summary card numbers"
- :group 'addrbook)
-
-(defface addrbook-summary-modified-flag
- '((((min-colors 88) (class color) (background light))
- :foreground "red1")
- (((class color) (background light))
- :foreground "red")
- (((min-colors 88) (class color) (background dark))
- :foreground "red")
- (((class color) (background dark))
- :foreground "red")
- (t
- :weight bold))
- "Face for summary modified flag"
- :group 'addrbook)
-
-(defface addrbook-summary-match-flag
- '((((min-colors 88) (class color) (background light))
- :foreground "brown")
- (((class color) (background light))
- :foreground "brown")
- (((min-colors 88) (class color) (background dark))
- :foreground "brown")
- (((class color) (background dark))
- :foreground "brown")
- (t
- :weight bold))
- "Face for summary match flag"
- :group 'addrbook)
-
-(defface addrbook-properties-group-name
- '((((min-colors 88) (class color) (background light))
- :foreground "red1")
- (((class color) (background light))
- :foreground "red")
- (((min-colors 88) (class color) (background dark))
- :foreground "yellow1")
- (((class color) (background dark))
- :foreground "yellow")
- (t
- :weight bold))
- "Face for properties group titles"
- :group 'addrbook)
-
-(defface addrbook-attribute-title-name
- '((((min-colors 88) (class color) (background light))
- )
- (((class color) (background light))
- )
- (((min-colors 88) (class color) (background dark))
- )
- (((class color) (background dark))
- )
- (t
- ))
- "Face for attribute titles"
- :group 'addrbook)
-
-(defface addrbook-contact-title
- '((((min-colors 88) (class color) (background light))
- :underline t
- )
- (((class color) (background light))
- :underline t
- )
- (((min-colors 88) (class color) (background dark))
- :underline t
- )
- (((class color) (background dark))
- :underline t
- )
- (t
- ))
- "Face for contact titles"
- :group 'addrbook)
-
-(defface addrbook-attribute-type
- '((((min-colors 88) (class color) (background light))
- :foreground "blue")
- (((class color) (background light))
- :foreground "blue")
- (((min-colors 88) (class color) (background dark))
- :foreground "blue")
- (((class color) (background dark))
- )
- (t
- ))
- "Face for attribute types"
- :group 'addrbook)
-
-(defface addrbook-attribute-value
- '((((min-colors 88) (class color) (background light))
- :foreground "grey")
- (((class color) (background light))
- :foreground "grey")
- (((min-colors 88) (class color) (background dark))
- :foreground "grey")
- (((class color) (background dark))
- :weight bold)
- (t
- :weight bold))
- "Face for attribute values"
- :group 'addrbook)
-
-(defface addrbook-summary-selected-card
- '((((min-colors 88) (class color) (background light))
- :background "grey"
- :foreground "black")
- (((class color) (background light))
- :background "grey"
- :foreground "black")
- (((min-colors 88) (class color) (background dark))
- :background "grey"
- :foreground "black"
- :weight bold)
- (((class color) (background dark))
- :weight bold)
- (t
- :weight bold))
- "Face for selected summary contact line"
- :group 'addrbook)
-
-;;;; * Variables
-
-(defvar addrbook-image-types
- '(("gif" nil)
- ("cgm" nil)
- ("wmf" nil)
- ("bmp" nil)
- ("met" nil)
- ("pbm" pbm)
- ("dib" nil)
- ("pict" nil)
- ("tiff" nil)
- ("pdf" nil)
- ("ps" postscript)
- ("jpeg" jpeg)
- ("mpeg" nil)
- ("mpeg2" nil)
- ("avi" nil)
- ("qtime" nil))
- "Association between vCard image types and emacs image types")
-
-(defvar addrbook-cards nil
- "Cards of the current addressbook")
-
-(defvar addrbook-modified-cards nil
- "Indexes of modified cards in addrbook-cards")
-
-(defvar addrbook-current-card nil
- "Number of current card")
-
-(defvar addrbook-properties
- '((identification-properties
- "Identification"
- (("fn" "Formatted Name" nil)
- ("n" "Name" ?n
- (("Surname" ?s)
- ("First name" ?f)
- ("AKA" ?a)
- ("Name prefix" ?p)
- ("Name suffix" ?x)))
- ("photo" "Photograph" ?p nil
- ("type" (("jpeg" "jpeg" ?j)
- ("gif" "gif" ?g)
- ("cgm" "cgm" ?c)
- ("wmf" "wmf" ?w)
- ("bmp" "bmp" ?b)
- ("met" "met" ?m)
- ("pbm" "pbm" ?p)
- ("dib" "dib" ?d)
- ("pict" "pict" ?i)
- ("tiff" "tiff" ?t)
- ("ps" "ps" ?s)
- ("pdf" "pdf" ?f)
- ("mpeg" "mpeg" ?e)
- ("mpeg2" "mpeg2" ?2)
- ("avi" "avi" ?v)
- ("qtime" "qtime" ?q))
- nil t))
- ("bday" "Birthdate" ?b nil))
- ?i)
- (delivering-addressing-properties
- "Delivering Addressing"
- (("adr" "Delivery Address" ?a
- (("Post office address" ?p)
- ("Extended address" ?e)
- ("Street" ?s)
- ("Locality" ?l)
- ("Region" ?r)
- ("Postal code" ?o)
- ("Country" ?c))
- ("type" (("home" "home" ?h)
- ("dom" "domestic" ?d)
- ("intl" "international" ?i)
- ("postal" "postal" ?p)
- ("parcel" "parcel" ?a)
- ("work" "work" ?w))
- t nil))
- ("label" "Delivery Label" ?l nil
- ("type" (("home" "home" ?h)
- ("dom" "domestic" ?d)
- ("intl" "international" ?i)
- ("postal" "postal" ?p)
- ("parcel" "parcel" ?a)
- ("work" "work" ?w))
- t nil)))
- ?d)
- (telecommunications-addressing-properties
- "Telecommunications Addressing"
- (("tel" "Telephone Number" ?t nil
- ("type" (("cell" "cellular" ?c)
- ("home" "home" ?h)
- ("pref" "preferred" ?p)
- ("work" "work" ?w)
- ("voice" "voice" ?v)
- ("fax" "facsimile" ?f)
- ("msg" "messaging service" ?m)
- ("pager" "pager" ?g)
- ("bbs" "bbs" ?b)
- ("modem" "modem" ?o)
- ("car" "car-phone" ?r)
- ("isdn" "isdn" ?i)
- ("video" "video-phone" ?d))
- t nil))
- ("email" "Electronic Mail" ?e nil
- ("type" (("internet" "smtp" ?s)
- ("aol" "America On-Line" ?l)
- ("applelink" "AppleLink" ?a)
- ("attmail" "AT&T" ?t)
- ("cis" "cis" ?c)
- ("cworld" "CWorld" ?w)
- ("ibmmail" "IBM mail" ?b)
- ("mcimail" "MCI mail" ?m)
- ("powershare" "powershare" ?p)
- ("prodigy" "prodigy" ?r)
- ("tlx" "telex" ?e)
- ("x400" "X.400" ?x))
- nil t))
- ("mailer" "Mailer" nil nil))
- ?t)
- (geographical-properties
- "Geographical"
- (("tz" "Time Zone" ?z nil)
- ("geo" "Geographic Position" ?g nil))
- ?g)
- (organizational-properties
- "Organizational"
- (("title" "Title" ?i nil)
- ("role" "Business Category" ?r nil)
- ("logo" "Business Logotype" ?w nil
- ("type" (("jpeg" "jpeg" ?j)
- ("gif" "gif" ?g)
- ("cgm" "cgm" ?c)
- ("wmf" "wmf" ?w)
- ("bmp" "bmp" ?b)
- ("met" "met" ?m)
- ("pbm" "pbm" ?p)
- ("dib" "dib" ?d)
- ("pict" "pict" ?i)
- ("tiff" "tiff" ?t)
- ("ps" "ps" ?s)
- ("pdf" "pdf" ?f)
- ("mpeg" "mpeg" ?e)
- ("mpeg2" "mpeg2" ?2)
- ("avi" "avi" ?v)
- ("qtime" "qtime" ?q))
- nil t))
- ("agent" "Agent" nil nil)
- ("org" "Organization" ?o
- (("Name" ?n)
- ("Unit" ?u)
- ("Additional units" ?a))))
- ?o)
- (explanatory-properties
- "Explanatory"
- (("note" "Comment" ?m nil)
- ("rev" "Last Revision" nil nil)
- ("sound" "Sound" ?d nil
- ("type" (("wave" "wave" ?w)
- ("pcm" "pcm" ?p)
- ("aiff" "aiff" ?a))
- nil t))
- ("url" "URL" ?u nil)
- ("uid" "Unique Identifier" nil nil)
- ("version" "Version of vCard" nil nil))
- ?e)
- (security-properties
- "Security"
- (("key" "Public Key" ?k nil
- ("type" (("pgp" "pgp" ?g)
- ("x509" "x509" ?x))
- nil t)))
- ?s))
- "vCard specification standard properties")
-
-(defvar addrbook-required-attrs '("n")
- "List of required attributes")
-
-(defvar addrbook-general-params
- '(("url" "value") ("content-id" "value"))
- "General vCard parameters")
-
-;;;; * Properties management functions
-
-;;;; ** Groups
-(defun addrbook-get-group (group-symbol)
- "Return the sexp containing information for GROUP"
- (assoc group-symbol addrbook-properties))
-
-(defun addrbook-get-group-symbol (group)
- (nth 0 group))
-
-(defun addrbook-get-group-name (group)
- (nth 1 group))
-
-(defun addrbook-get-group-props (group)
- (nth 2 group))
-
-(defun addrbook-get-group-letter (group)
- (nth 3 group))
-
-(defun addrbook-group-has-properties-p (group)
- (let ((group-attrs (addrbook-get-group-props group))
- (result nil))
- (dolist (attr (addrbook-get-card addrbook-current-card))
- (if (and (addrbook-property-in-group-p attr group-attrs)
- (not (member (vcard-attr-get-name attr)
addrbook-contact-properties-nodisplay)))
- (setq result t)))
- result))
-
-;;;; ** Properties
-
-(defun addrbook-get-group-prop (props prop-name)
- (assoc prop-name props))
-
-(defun addrbook-get-prop-name (property)
- (nth 0 property))
-
-(defun addrbook-get-prop-title (property)
- (nth 1 property))
-
-(defun addrbook-get-prop-letter (property)
- (nth 2 property))
-
-(defun addrbook-get-prop-fields-list (property)
- (nth 3 property))
-
-(defun addrbook-get-prop-fields (property)
- (let ((fields (addrbook-get-prop-fields-list property))
- (result nil) field)
- (dolist (field fields)
- (setq result (cons (car field) result)))
- (reverse result)))
-
-(defun addrbook-get-prop-field-name (field)
- (nth 0 field))
-
-(defun addrbook-get-prop-field-letter (field)
- (nth 1 field))
-
-(defun addrbook-get-prop-index (prop-fields field-name)
- (let ((index 0) result)
- (dotimes (index (length prop-fields) result)
- (if (equal (nth index prop-fields) field-name)
- (setq result index)))))
-
-(defun addrbook-get-prop-field-description (fields field-name)
- (cadr (assoc field-name fields)))
-
-(defun addrbook-get-prop-parameters (prop)
- (nthcdr 4 prop))
-
-(defun addrbook-get-prop-parameter (prop param-name)
- (let ((prop-parameters (addrbook-get-prop-parameters prop)))
- (cadr (assoc param-name prop-parameters))))
-
-(defun addrbook-prop-parameter-allow-duplicates (prop param-name)
- (let ((prop-parameters (addrbook-get-prop-parameters prop)))
- (nth 2 (assoc param-name prop-parameters))))
-
-(defun addrbook-prop-parameter-is-mandatory (prop param-name)
- (let ((prop-parameters (addrbook-get-prop-parameters prop)))
- (nth 3 (assoc param-name prop-parameters))))
-
-(defun addrbook-property-in-group-p (attr group-props)
- (let ((attr-name (vcard-attr-get-name attr)))
- (when (assoc attr-name group-props)
- t)))
-
-(defun addrbook-get-property (attr-name)
- (let (group result)
- (dolist (group addrbook-properties)
- (let* ((group-props (addrbook-get-group-props group))
- (group-prop (addrbook-get-group-prop group-props attr-name)))
- (if group-prop
- (setq result group-prop))))
- result))
-
-(defun addrbook-get-prop-default-type (prop-name)
- (let* ((property (addrbook-get-property prop-name))
- (prop-type (addrbook-get-prop-parameter property "type")))
- (when prop-type
- (car (car prop-type)))))
-
-;;;; ** Cards
-
-(defun addrbook-get-card (numcard)
- (nth numcard addrbook-cards))
-
-(defun addrbook-set-card (numcard card)
- (if addrbook-cards
- (cond
- ((and (>= numcard 0) (< numcard (length addrbook-cards)))
- (setcar (nthcdr numcard addrbook-cards) card))
- ((>= numcard (length addrbook-cards))
- (setq addrbook-cards (append addrbook-cards (list card)))))
- (setq addrbook-cards (list card))))
-
-(defun addrbook-remove-card (numcard)
- (setq addrbook-cards (delete (addrbook-get-card numcard)
- addrbook-cards)))
-
-(defun addrbook-value-empty-p (values)
- "Return t if VALUES is empty"
- (when (listp values)
- (if (cdr values)
- (when (equal (car values) "")
- (addrbook-value-empty-p (cdr values)))
- (equal (car values) ""))))
-
-(defun addrbook-number-of-values (values)
- (if (listp values)
- (let (value
- (nov 0))
- (dolist (value values nov)
- (if (not (equal value ""))
- (setq nov (+ nov 1)))))
- 1))
-
-(defun addrbook-get-card-fn (&optional with-aka card-number)
- (let* ((card (addrbook-get-card (if card-number
- card-number
- addrbook-current-card)))
- (name-attr (vcard-get-named-attribute card "n"))
- (name-attr-values (vcard-attr-get-values name-attr))
- (name-surname (nth 0 name-attr-values))
- (name-surname-p (and name-surname
- (not (equal name-surname ""))))
- (name-first-name (nth 1 name-attr-values))
- (name-first-name-p (and name-first-name
- (not (equal name-first-name ""))))
- (name-aka (nth 2 name-attr-values))
- (name-aka-p (and name-aka
- (not (equal name-aka ""))))
- (name-prefix (nth 3 name-attr-values))
- (name-prefix-p (and name-prefix
- (not (equal name-prefix ""))))
- (name-suffix (nth 4 name-attr-values))
- (name-suffix-p (and name-suffix
- (not (equal name-suffix ""))))
- (result ""))
- (when name-prefix-p
- (setq result (concat result name-prefix)))
- (when name-first-name-p
- (setq result (concat result
- (when name-prefix-p " ")
- name-first-name)))
- (when name-surname-p
- (setq result (concat result
- (when (or name-prefix-p
- name-first-name-p) " ")
- name-surname)))
- (when name-suffix-p
- (setq result (concat result
- (when (or name-prefix-p
- name-first-name-p
- name-surname-p) " ")
- name-suffix)))
- (when (and with-aka name-aka-p)
- (setq result (concat result
- (when (or name-prefix-p
- name-first-name-p
- name-surname-p
- name-suffix-p) " ")
- "(" name-aka ")")))
- result))
-
-;;;; ** Attributes
-
-(defun addrbook-delete-attr (attr-index attr-subindex)
- (let* ((card (addrbook-get-card addrbook-current-card))
- (attr (vcard-get-attribute card attr-index))
- (attr-value (vcard-attr-get-values attr)))
- (if attr-subindex
- (progn
- ;; Delete the field from the values
- (setcar (nthcdr attr-subindex attr-value) "")
- (vcard-attr-set-values attr attr-value)
- (if (addrbook-value-empty-p attr-value)
- (addrbook-set-card addrbook-current-card
(vcard-delete-indexed-attribute card attr-index))))
- ;; Delete the attribute
- (addrbook-set-card addrbook-current-card (vcard-delete-indexed-attribute
card attr-index)))))
-
-(defun addrbook-build-custom-property-group ()
- "Return an empty custom property group"
- (list 'custom-properties
- "Custom Properties"
- nil
- ?c))
-
-(defun addrbook-set-custom-properties (props-data)
-"This function accepts a list of the form:
-
- (PROP1 PROP2 ... PROPN)
-
-where each property PROP is defined with the following structure:
-
- (\"property-name\" \"Property displayed name\"
- ?character-identifying-the-group-for-fast-selection
- (FIELD1 FIELD2 ... FIELDN)
- (\"type\"
- ((\"type1\" \"type1 displayed name\" ?fast-selection-char1)
- (\"type2\" \"type 2 displayed name\" ?fast-selection-char2)
- ...)
- allow-several-types-p at-least-one-type-mandatory-p))
-
-where each field FIELD is defined with the following structure:
-
- (\"Field name\" ?character-identifying-the-field-for-fast-selection)"
- (let (custom-group
- prop)
- (dolist (prop props-data)
- (setcar prop (concat "x-emacs-" (car prop))))
- (when (not (addrbook-get-group 'custom-properties))
- (setq addrbook-properties
- (append addrbook-properties (list
(addrbook-build-custom-property-group)))))
- (setq custom-group (addrbook-get-group 'custom-properties))
- (setcar (nthcdr 2 custom-group) props-data)))
-
-
-;;;; * Addressbook contact editor
-
-;;;; ** Constants
-
-(defconst addrbook-contact-buffer-name "*AddressBook Contact*"
- "Name of the buffer for the addressbook contact editor")
-
-;;;; ** Variables
-
-(defvar addrbook-contact-properties-nodisplay
- '("sound" "agent" "version" "uid" "label" "mailer" "uid"))
-
-(defvar addrbook-contact-mode-map nil
- "Keymap for addrbook-contact-mode")
-
-(defvar addrbook-contact-displayed-groups nil
- "List of displayed property groups")
-
-(defvar addrbook-contact-mode-line-string " ABook Contact"
- "String to display on the mode line when in the addressbook mode.
-If `nil', do not show anything.")
-
-;;;; ** Contact buffer management
-
-(defun addrbook-create-contact-buffer ()
- "Create a new addressbook buffer to show contact information"
- (setq buffer (get-buffer-create addrbook-contact-buffer-name))
- (set-buffer buffer)
- (addrbook-contact-mode))
-
-(defun addrbook-show-contact ()
- (let ((buffer (get-buffer addrbook-contact-buffer-name)))
- (if addrbook-use-multiple-frames
- (switch-to-buffer-other-window buffer)
- (switch-to-buffer buffer))))
-
-;;;; ** Display functions
-
-(defun addrbook-contact-display-card (numcard)
- "Display the NUMCARD card into the addressbook buffer"
- (save-excursion
- (let ((card (addrbook-get-card numcard)))
- (if card
- (progn
- (erase-buffer)
- (setq addrbook-current-card numcard)
- (insert "\n\n")
- ;; Reset displayed groups list
- (setq addrbook-contact-displayed-groups nil)
- ;; Display groups
- (mapcar #'addrbook-contact-display-group addrbook-properties)
- ;; Hide all groups not present in addrbook-display-groups
- (dolist (group addrbook-contact-displayed-groups nil)
- (if (not (member group addrbook-display-groups))
- (addrbook-contact-hide-show-group group nil)))
- ;; Set mode line contents
- (addrbook-contact-set-mode-line (+ addrbook-current-card 1)
- (length addrbook-cards)))))))
-
-(defun addrbook-contact-display-group (group)
- (if (addrbook-group-has-properties-p group)
- (let ((group-region-begin (make-marker))
- (group-region-end nil))
- (set-marker group-region-begin (point))
- (addrbook-contact-display-properties group)
- (insert "\n")
- (setq group-region-end (point))
- (put-text-property (marker-position group-region-begin)
- group-region-end
- 'group-region (car group)))))
-
-(defun addrbook-contact-display-properties (group)
- "Display the GROUP properties from the current card"
- (let* ((card (addrbook-get-card addrbook-current-card))
- (group-name (addrbook-get-group-name group))
- (group-props (addrbook-get-group-props group))
- (num-attributes (vcard-get-num-attributes card))
- (i 0))
- ;; Mark this group as displayed
- (add-to-list 'addrbook-contact-displayed-groups (addrbook-get-group-symbol
group))
- (insert (propertize group-name 'face 'addrbook-properties-group-name
- 'group (addrbook-get-group-symbol group)))
- (insert "\n\n")
- (dolist (property group-props)
- (dotimes (i num-attributes)
- (let ((attr (vcard-get-attribute card i)))
- (if (and (equal (vcard-attr-get-name attr) (addrbook-get-prop-name
property))
- (not (addrbook-contact-attribute-nodisplay attr
addrbook-contact-properties-nodisplay))
- (addrbook-property-in-group-p attr group-props))
- (addrbook-contact-display-attribute i)))))))
-
-(defun addrbook-contact-attribute-nodisplay (attr nodisplay-attrs)
- (let ((attr-name (vcard-attr-get-name attr)))
- (if nodisplay-attrs
- (or (equal (car nodisplay-attrs) attr-name)
- (addrbook-contact-attribute-nodisplay attr (cdr nodisplay-attrs))))))
-
-(defun addrbook-contact-display-attribute (attr-index)
- "Display the ATTR-INDEXth attribute"
- (let* ((card (addrbook-get-card addrbook-current-card))
- (attr (vcard-get-attribute card attr-index))
- (attr-name (vcard-attr-get-name attr)))
- (cond
- ((equal attr-name "fn")
- t)
- ((equal attr-name "n")
- (addrbook-contact-display-attribute-n attr-index))
- ((or (equal attr-name "photo")
- (equal attr-name "logo"))
- (addrbook-contact-display-attribute-photo-logo attr-index))
- (t
- (addrbook-contact-display-attribute-regular attr-index)))))
-
-(defun addrbook-contact-display-attribute-n (attr-index)
- (let* ((card (addrbook-get-card addrbook-current-card))
- (attr (vcard-get-attribute card attr-index))
- (attr-value (vcard-attr-get-values attr))
- (surname (nth 0 attr-value))
- (name (nth 1 attr-value))
- (additional-names (nth 2 attr-value))
- (name-prefix (nth 3 attr-value))
- (name-suffix (nth 4 attr-value)))
- (addrbook-contact-display-attribute-regular attr-index)
- ;; Insert name on the first line
- (save-excursion
- (goto-char (point-min))
- (if (get-text-property (point) 'title)
- (addrbook-erase-tagged-region 'title))
- (insert (propertize
- (addrbook-get-card-fn t)
- 'face 'addrbook-contact-title
- 'title t)))))
-
-(defun addrbook-contact-display-attribute-photo-logo (attr-index)
- "Display photo from ATTR-INDEX.
-Only display it if not already displayed and/or image type is
-supported and if `display-images-p' is non nil.
-
-ATTR-INDEX can represent eith an inlined data or an offline url.
-When ressource is of type URL, we use url package to get the image data."
- (let* ((card (addrbook-get-card addrbook-current-card))
- (attr (vcard-get-attribute card attr-index))
- (attr-value (car (vcard-attr-get-values attr)))
- (photo-type (car (vcard-attr-get-parameter attr "type")))
- (photo-value (car (vcard-attr-get-parameter attr "value")))
- (image-type nil)
- (image-data nil))
- (addrbook-contact-display-attribute-regular attr-index)
- ;; Insert photo in buffer
- ;; Determine emacs image type
- (setq image-type
- (cadr (assoc photo-type addrbook-image-types)))
-
- ;; Display the image or a link
- (when (and addrbook-display-images
- (display-images-p)
- image-type
- (image-type-available-p image-type)
- (not (addrbook-contact-photo-displayed-p)))
-
- ;; Get image data
- (let ((image-data
- (if (equal photo-value "url")
- (save-excursion
- (require 'url)
-
- (let ((image-buffer (url-retrieve-synchronously attr-value)))
- (if image-buffer
- (unwind-protect
- (with-current-buffer image-buffer
- ;; FIXME: could be more robust
- (goto-char (point-min))
- (re-search-forward "^\r?$" nil 1)
- (forward-line)
- (delete-region (point-min) (point))
-
- (setq image-data (string-as-unibyte
(buffer-string))))
- (kill-buffer image-buffer)))))
- attr-value)))
-
- ;; Display the image
- (save-excursion
- (goto-char (point-min))
- (goto-char (line-end-position))
- (insert "\n\n")
- (insert-image (create-image image-data image-type t)
- (propertize "[photo]"
- 'identification-photo t
- 'attr-index attr-index
- 'attr-subindex nil)))))))
-
-(defun addrbook-contact-display-attribute-regular (attr-index)
- (let* ((card (addrbook-get-card addrbook-current-card))
- (attr (vcard-get-attribute card attr-index))
- (attr-name (vcard-attr-get-name attr))
- (attr-value (vcard-attr-get-values attr))
- (property (addrbook-get-property attr-name))
- (prop-title (addrbook-get-prop-title property))
- (prop-fields (addrbook-get-prop-fields property))
- (attr-type (car (vcard-attr-get-parameter attr "type")))
- (attr-region-begin nil)
- (attr-region-end nil))
- (setq attr-region-begin (point))
- (if prop-fields
- (progn
- ;; Insert attribute fields instead of name
- (insert (make-string addrbook-attribute-indentation ?\ ))
- (insert (propertize prop-title
- 'face 'addrbook-attribute-title-name
- 'attr-compound-title t
- 'attr-index attr-index))
- (addrbook-contact-display-attribute-type attr-index)
- (insert ":")
- (insert "\n")
- (dotimes (i (length prop-fields))
- (let ((value (nth i attr-value)))
- (if (and value
- (not (equal value "")))
- (progn
- (insert (make-string
- (+ addrbook-field-indentation
- addrbook-attribute-indentation)
- ?\ ))
- (insert (propertize (nth i prop-fields)
- 'face 'addrbook-attribute-title-name
- 'attr-index attr-index
- 'attr-subindex i))
- (insert ":")
- (insert " ")
- (insert (propertize (nth i attr-value)
- 'face 'addrbook-attribute-value
- 'attr-index attr-index
- 'attr-subindex i))
- (insert "\n"))))))
- ;; Insert attribute title
- (insert " ")
- (insert (propertize prop-title
- 'face 'addrbook-attribute-title-name
- 'attr-index attr-index
- 'attr-subindex nil))
- (addrbook-contact-display-attribute-type attr-index)
- (insert ":")
- (insert " ")
- ;; Insert attribute value
- (insert (propertize (car attr-value)
- 'face 'addrbook-attribute-value
- 'attr-index attr-index
- 'attr-subindex nil))
- (insert "\n"))
-
- (setq attr-region-end (point))
- (put-text-property attr-region-begin attr-region-end
- 'attr-region attr-index)))
-
-(defun addrbook-contact-display-attribute-type (attr-index)
- (let* ((card (addrbook-get-card addrbook-current-card))
- (attr (vcard-get-attribute card attr-index))
- (attr-name (vcard-attr-get-name attr))
- (property (addrbook-get-property attr-name))
- (type-param (addrbook-get-prop-parameter property "type"))
- (attr-type-params (vcard-attr-get-parameter attr "type"))
- attr-type
- prop-type-param
- printable-type-list)
- (dolist (attr-type attr-type-params)
- (setq printable-type-list
- (cons (nth 1 (assoc attr-type type-param)) printable-type-list)))
- (setq printable-type-list (reverse printable-type-list))
- (when attr-type-params
- (insert " ")
- (insert "(")
- (insert (propertize
- (addrbook-list-to-csv printable-type-list)
- 'face 'addrbook-attribute-type))
- (insert ")"))))
-
-(defun addrbook-contact-group-hidden-p (group)
- (save-excursion
- (let ((group-exist (addrbook-contact-goto-group group)))
- (and group-exist
- (get-text-property group-exist 'invisible)))))
-
-(defun addrbook-contact-hide-show-group (group show-p)
- "Hide GROUP attributes from the screen"
- (save-excursion
- (let ((group-exist (addrbook-contact-goto-group group))
- (group-real-begin-pos nil)
- (group-end-pos nil)
- (group-begin-pos nil))
- (when group-exist
- (setq group-real-begin-pos (next-single-property-change (point)
'group))
- (goto-char group-real-begin-pos)
- (setq group-end-pos (next-single-property-change (point) 'group))
- (if (not group-end-pos)
- (setq group-end-pos (point-max)))
- (if show-p
- (progn
- (remove-text-properties group-real-begin-pos
- (- group-end-pos 1)
- '(invisible nil)))
- (put-text-property group-real-begin-pos
- (- group-end-pos 1)
- 'invisible t))))))
-
-(defun addrbook-contact-get-current-group ()
- "Return the group affecting current buffer point, or nil"
- (let ((prop-change-pos (previous-single-property-change
- (point) 'group)))
- (when prop-change-pos
- (save-excursion
- (goto-char (- prop-change-pos 1))
- (get-text-property (point) 'group)))))
-
-(defun addrbook-contact-get-current-attr-index ()
- "Return the attribute index of the attribute displayed in the current line"
- (addrbook-get-text-property-line 'attr-index))
-
-(defun addrbook-contact-get-current-attr-subindex ()
- "Return the attribute subindex of the attribute displayed in the current
line"
- (addrbook-get-text-property-line 'attr-subindex))
-
-(defun addrbook-contact-get-current-attr-compound-title ()
- (addrbook-get-text-property-line 'attr-compound-title))
-
-(defun addrbook-contact-goto-group (group)
- "Leave the point at the beginning of GROUP"
- (let ((group-begin-pos nil)
- (found nil)
- (group-exist t))
- ;; Search for the first non-nil 'group
- ;; property change with 'group == GROUP
- (goto-char (point-min))
- (while (not found)
- (setq group-begin-pos (next-single-property-change (point) 'group))
- (if group-begin-pos
- (progn
- (goto-char group-begin-pos)
- (if (eq (get-text-property (point) 'group) group)
- (setq found t)))
- (setq found t)
- (setq group-exist nil)))
- group-exist))
-
-(defun addrbook-contact-redisplay-card ()
- "Redisplay current card"
- (erase-buffer)
- (addrbook-contact-display-card addrbook-current-card))
-
-(defun addrbook-contact-redisplay-group (group)
- "Redisplay GROUP in the screen"
- (save-excursion
- (let ((group-exist (addrbook-contact-goto-group group)))
- (when group-exist
- ;; Remove old group contents
- (addrbook-contact-erase-group-region)
- ;; Display the group
- (addrbook-contact-display-group (addrbook-get-group group))))))
-
-(defun addrbook-contact-erase-group-region ()
- "Erase the region used by the group in point"
- (addrbook-erase-tagged-region 'group-region))
-
-(defun addrbook-contact-erase-attr-region ()
- "Erase the region used by the attribute in point"
- (addrbook-erase-tagged-region 'attr-region))
-
-(defun addrbook-contact-redisplay-attr-at-point ()
- "Redisplay the attribute at point"
- (let* ((column-backup (current-column))
- (line-backup (line-number-at-pos (point)))
- (group-symbol (addrbook-contact-get-current-group))
- (attr-index (addrbook-contact-get-current-attr-index)))
- (if (and group-symbol attr-index)
- (let* ((card (addrbook-get-card addrbook-current-card))
- (group (addrbook-get-group group-symbol))
- (group-attrs (addrbook-get-group-props group))
- group-aregion-begin group-region-end)
- (addrbook-contact-erase-attr-region)
- (setq group-region-begin (point))
- (addrbook-contact-display-attribute attr-index)
- (setq group-region-end (point))
- (put-text-property group-region-begin
- group-region-end
- 'group-region group-symbol)
- (goto-line line-backup)
- (goto-char (+ (line-beginning-position) column-backup))))))
-
-(defun addrbook-contact-in-display-p (group-symbol)
- (addrbook-contact-goto-group group-symbol))
-
-(defun addrbook-contact-photo-displayed-p ()
- (next-single-property-change (point-min) 'identification-photo))
-
-;;;; ** Commands
-
-(defun addrbook-contact-add-attribute-type ()
- "Add a new type to the attribute under point"
- (interactive)
- (let ((buffer-read-only nil)
- (point-backup (point))
- (group-symbol (addrbook-contact-get-current-group))
- (attr-index (addrbook-contact-get-current-attr-index))
- (attr-subindex (addrbook-contact-get-current-attr-subindex)))
- (if (and attr-index
- (not attr-subindex))
- (let* ((card (addrbook-get-card addrbook-current-card))
- (attr (vcard-get-attribute card attr-index))
- (attr-name (vcard-attr-get-name attr))
- (property (addrbook-get-property attr-name))
- (prop-types (addrbook-get-prop-parameter property "type")))
- (if prop-types
- (let ((new-type (addrbook-select-non-existing-type attr))
- type result)
- (dolist (type prop-types)
- (if (equal (cadr type)
- new-type)
- (setq result (car type))))
- (when result
- (if (addrbook-prop-parameter-allow-duplicates property
"type")
- ;; Add the new type
- (vcard-attr-add-property attr "type" result)
- ;; Replace current type
- (vcard-attr-set-property attr "type" result))
- ;; Redisplay attribute
- (addrbook-contact-redisplay-attr-at-point)
- ;; Addressbook modified
- (add-to-list 'addrbook-modified-cards
addrbook-current-card))))))
- (goto-char point-backup)))
-
-(defun addrbook-contact-remove-attribute-type ()
- "Remove a type from the attribute under point"
- (interactive)
- (let ((buffer-read-only nil)
- (point-backup (point))
- (group-symbol (addrbook-contact-get-current-group))
- (attr-index (addrbook-contact-get-current-attr-index))
- (attr-subindex (addrbook-contact-get-current-attr-subindex)))
- (if (and attr-index
- (not attr-subindex))
- (let* ((card (addrbook-get-card addrbook-current-card))
- (attr (vcard-get-attribute card attr-index))
- (attr-name (vcard-attr-get-name attr))
- (property (addrbook-get-property attr-name))
- (prop-types (addrbook-get-prop-parameter property "type")))
- (if prop-types
- (if (and (equal (length (vcard-attr-get-parameter attr "type"))
1)
- (addrbook-prop-parameter-is-mandatory property "type"))
- (message "This attribute should have a type")
- (let ((new-type (addrbook-select-existing-type attr))
- type result)
- (dolist (type prop-types)
- (if (equal (cadr type)
- new-type)
- (setq result (car type))))
- (when result
- ;; Add the new type
- (vcard-attr-remove-property attr "type" result)
- ;; Redisplay attribute
- (addrbook-contact-redisplay-attr-at-point)
- ;; Addressbook modified
- (add-to-list 'addrbook-modified-cards
addrbook-current-card)))))))
- (goto-char point-backup)))
-
-(defun addrbook-contact-delete-attribute ()
- "Delete the attribute under point"
- (interactive)
- (let ((buffer-read-only nil)
- (point-backup (point))
- (group-symbol (addrbook-contact-get-current-group))
- (attr-index (addrbook-contact-get-current-attr-index))
- (attr-subindex (addrbook-contact-get-current-attr-subindex)))
- (if (and group-symbol attr-index)
- (let* ((group (addrbook-get-group group-symbol))
- (group-attrs (addrbook-get-group-props group))
- (card (addrbook-get-card addrbook-current-card))
- (attr (vcard-get-attribute card attr-index))
- (attr-name (vcard-attr-get-name attr))
- (attr-value (vcard-attr-get-values attr))
- (group-attr (addrbook-get-group-prop group-attrs attr-name))
- (attr-title (addrbook-get-prop-title group-attr))
- (attr-fields (addrbook-get-prop-fields-list group-attr))
- (attr-field (when attr-subindex (nth attr-subindex attr-fields)))
- (attr-field-name (when attr-field (addrbook-get-prop-field-name
attr-field)))
- (prompt (concat "Are you sure you want to delete "
- (if attr-subindex
- (concat "field " attr-field-name)
- (concat "attribute " attr-title))
- "? "))
- elt)
- (if (yes-or-no-p prompt)
- (if (and (member attr-name addrbook-required-attrs)
- (or (addrbook-contact-get-current-attr-compound-title)
- (equal (addrbook-number-of-values attr-value) 1)))
- (error "Trying to delete a required attribute")
- (addrbook-delete-attr attr-index attr-subindex)
- (if (not (equal attr-name "photo"))
- (addrbook-contact-redisplay-group group-symbol)
- (addrbook-contact-redisplay-card))))))
- (goto-char point-backup)
- (add-to-list 'addrbook-modified-cards addrbook-current-card)))
-
-(defun addrbook-contact-add-attribute ()
- "Add a new attribute to the current card"
- (interactive)
- (let* (buffer-read-only
- (backup-point (point))
- group-symbol
- group group-attrs
- (i 0)
- (current-card (addrbook-get-card addrbook-current-card)))
- ;; Get group
- (setq group-symbol (or (addrbook-contact-get-current-group)
- (addrbook-select-group)))
- (setq group (addrbook-get-group group-symbol))
- (setq group-attrs (addrbook-get-group-props group))
- (if group-symbol
- (let (attr-index attr-subindex property-index)
- ;; Get property
- (setq attr-index (addrbook-contact-get-current-attr-index))
- (setq attr-subindex (addrbook-contact-get-current-attr-subindex))
- (if (and attr-index attr-subindex)
- (let ((attr (vcard-get-attribute current-card attr-index)))
- (setq property-name (vcard-attr-get-name attr)))
- (setq property-name (addrbook-select-property group-symbol)))
- (if property-name
- (let* ((property (addrbook-get-group-prop group-attrs
property-name))
- (property-title (addrbook-get-prop-title property))
- (property-fields (addrbook-get-prop-fields property))
- field-index (property-value "") prompt
- (continue t))
- ;; Get field
- (when property-fields
- (setq field-index (addrbook-select-field group-symbol
property-name))
- (setq continue field-index))
- (when continue
- ;; Ask for a new value for the property or field
- (setq prompt (concat
- property-title
- (if field-index
- (concat " ("
- (nth field-index property-fields)
- ")"))
- ": "))
- ;; Read value from minibuffer
- (while (equal property-value "")
- (setq property-value
- (read-from-minibuffer prompt)))
- (if (and attr-index property-fields)
- (let* ((attr (vcard-get-attribute current-card
attr-index))
- (attr-values (vcard-attr-get-values attr))
- (attr-value (nthcdr field-index attr-values)))
- ;; Add a field to a specific attribute
- (if attr-value
- (setcar attr-value property-value)
- (setq attr-values (reverse attr-values))
- ;; Add enough empty values and then the new value
- (dotimes (i (- field-index (length attr-values)))
- (setq attr-values (cons "" attr-values)))
- (setq attr-values (cons property-value attr-values))
- (setq attr-values (reverse attr-values))
- (vcard-attr-set-values attr attr-values)))
- ;; Create a new attribute
- (let* ((new-attr-type (addrbook-get-prop-default-type
property-name))
- (new-attr-name property-name)
- (new-attr-values property-value)
- new-attr)
- (setq new-attr (list (list new-attr-name)
- new-attr-values))
- (vcard-attr-set-property new-attr "type" new-attr-type)
- (if (equal new-attr-name "photo")
- (vcard-attr-set-property new-attr "value" "url"))
- (setq current-card (vcard-add-attribute current-card
new-attr))))
- (addrbook-set-card addrbook-current-card current-card)
- (if (addrbook-contact-in-display-p group-symbol)
- (progn
- ;; Redisplay the group with new contents
- (addrbook-contact-redisplay-group group-symbol)
- ;; Hide the group if it was hidden
- (if (addrbook-contact-group-hidden-p group)
- (addrbook-contact-hide-show-group group nil)))
- ;; Redisplay the entire card
- (addrbook-contact-redisplay-card))
- ;; This card has been modified
- (add-to-list 'addrbook-modified-cards
addrbook-current-card))))))
- (goto-char backup-point)))
-
-(defun addrbook-contact-edit-attribute ()
- (interactive)
- "Edit the value of the attribute located in the current line"
- (let ((buffer-read-only nil)
- (group-symbol (addrbook-contact-get-current-group))
- (attr-index (addrbook-contact-get-current-attr-index))
- (attr-subindex (addrbook-contact-get-current-attr-subindex))
- (attr-compound-title-p
(addrbook-contact-get-current-attr-compound-title)))
- (if (and group-symbol attr-index (not attr-compound-title-p))
- (let* ((group (addrbook-get-group group-symbol))
- (group-attrs (addrbook-get-group-props group))
- (card (addrbook-get-card addrbook-current-card))
- (attr (vcard-get-attribute card attr-index))
- (attr-name (vcard-attr-get-name attr))
- (attr-value (vcard-attr-get-values attr))
- (group-attr (addrbook-get-group-prop group-attrs attr-name))
- (attr-fields (addrbook-get-prop-fields group-attr))
- (attr-real-value (if attr-subindex
- (nth attr-subindex attr-value)
- (car attr-value)))
- (attr-real-name (if attr-subindex
- (nth attr-subindex attr-fields)
- (addrbook-get-prop-title group-attr)))
- (new-value nil))
- ;; Ask for a new value for the attribute
- (setq new-value
- (read-from-minibuffer (concat attr-real-name ": ")
- attr-real-value))
- ;; Set the new value into the cards list
- ;; attr-fields[attr-subindex], attr-value, attr
- (let ((new-values nil))
- (if attr-subindex
- (setcar (nthcdr attr-subindex attr-value) new-value)
- (setq new-values (list new-value))
- (vcard-attr-set-values attr new-values)))
- ;; FIXME: update Last Revision field
- ;; Mark the current card as modified
- (add-to-list 'addrbook-modified-cards addrbook-current-card)
- ;; Redisplay attribute
- ;; FIXME: use addrbook-contact-redisplay-attr-at-point
- (let ((column-backup (current-column))
- (line-backup (line-number-at-pos (point))))
- (addrbook-contact-erase-attr-region)
- (addrbook-contact-display-attribute attr-index)
- (goto-line line-backup)
- (goto-char (+ (line-beginning-position) column-backup)))))))
-
-(defun addrbook-contact-goto-next-group ()
- "Leave the point at the beginning of the next group"
- (let ((next-point))
- (setq next-point (next-single-property-change (point) 'group))
- (when next-point
- (if (get-text-property next-point 'group)
- (goto-char next-point)
- (goto-char next-point)
- (setq next-point (next-single-property-change (point) 'group))
- (when next-point
- (goto-char next-point))))))
-
-(defun addrbook-contact-toggle-hide-show-group ()
- "When staying on a parameters group title, toggle visibility of the group"
- (interactive)
- (let ((buffer-read-only nil)
- (group (get-text-property (point) 'group))
- (group-content-pos nil))
- (when group
- ;; Search for visibility properties in group contents
- (setq group-content-pos (next-single-property-change (point) 'group))
- (if (get-text-property group-content-pos 'invisible)
- (addrbook-contact-hide-show-group group t)
- (addrbook-contact-hide-show-group group nil)))))
-
-(defun addrbook-contact-hide-all-groups ()
- "Hide all displayed groups"
- (interactive)
- (let (buffer-read-only)
- (dolist (group addrbook-contact-displayed-groups nil)
- (addrbook-contact-hide-show-group group nil))))
-
-(defun addrbook-contact-show-all-groups ()
- "Show all displayed groups"
- (interactive)
- (let (buffer-read-only)
- (dolist (group addrbook-contact-displayed-groups nil)
- (addrbook-contact-hide-show-group group t))))
-
-(defun addrbook-contact-cycle-groups ()
- "Cycle to next group"
- (interactive)
- (let ((next-group-pos (addrbook-contact-goto-next-group)))
- (when (not next-group-pos)
- (goto-char (point-min))
- (addrbook-contact-goto-next-group))))
-
-;;;; ** Modeline management
-
-(defun addrbook-contact-set-mode-line (card-number total-cards)
- "Update the modeline of the current buffer"
- ;; FIXME: this is ugly
- (when addrbook-contact-mode-line-string
- (setq mode-line-buffer-identification
- (list 24
- addrbook-contact-mode-line-string
- ": "
- (list 10
- (format "%d/%d" card-number total-cards))))))
-
-;;;; ** Major mode
-(defun addrbook-contact-mode ()
- "A major mode for contact editing
-
-Commands:
-\\{addrbook-contact-mode-map}"
- (interactive)
- (kill-all-local-variables)
- (setq addrbook-contact-mode-map (make-keymap))
- (define-key addrbook-contact-mode-map "c" 'addrbook-create-card)
- (define-key addrbook-contact-mode-map "D" 'addrbook-delete-card)
- (define-key addrbook-contact-mode-map "n" 'addrbook-next-contact)
- (define-key addrbook-contact-mode-map "p" 'addrbook-previous-contact)
- (define-key addrbook-contact-mode-map "s" 'addrbook-save-cards)
- (define-key addrbook-contact-mode-map "x" 'addrbook-export-card)
- (define-key addrbook-contact-mode-map "b" 'addrbook-bury)
- (define-key addrbook-contact-mode-map "q" 'addrbook-quit)
- (define-key addrbook-contact-mode-map "e"
'addrbook-contact-edit-attribute)
- (define-key addrbook-contact-mode-map (kbd "SPC")
'addrbook-contact-toggle-hide-show-group)
- (define-key addrbook-contact-mode-map (kbd "TAB")
'addrbook-contact-cycle-groups)
- (define-key addrbook-contact-mode-map "d"
'addrbook-contact-delete-attribute)
- (define-key addrbook-contact-mode-map "a"
'addrbook-contact-add-attribute)
- (define-key addrbook-contact-mode-map "t"
'addrbook-contact-add-attribute-type)
- (define-key addrbook-contact-mode-map "r"
'addrbook-contact-remove-attribute-type)
- (define-key addrbook-contact-mode-map "m" 'addrbook-send-email)
- (define-key addrbook-contact-mode-map "H"
'addrbook-contact-hide-all-groups)
- (define-key addrbook-contact-mode-map "S"
'addrbook-contact-show-all-groups)
- (define-key addrbook-contact-mode-map "h" 'addrbook-summarize)
- (use-local-map addrbook-contact-mode-map)
- (setq mode-name "ABook Contact")
- (setq major-mode 'addrbook-contact-mode))
-
-;;;; * Addressbook Summary
-
-;;;; ** Constants
-
-(defconst addrbook-summary-buffer-name "*AddressBook Summary*"
- "Name of the buffer for the addressbook summary")
-
-;;;; ** Variables
-
-(defvar addrbook-summary-mode-map nil
- "Keymap for addrbook-summary-mode")
-
-(defvar addrbook-summary-mode-line-string " ABook Summary"
- "String to display on the mode line when in the addressbook summary mode.
-If `nil', do not show anything.")
-
-;;;; ** Summary buffer management
-
-(defun addrbook-make-summary-buffer ()
- (save-excursion
- (let ((buffer (get-buffer-create addrbook-summary-buffer-name)))
- (set-buffer buffer)
- (addrbook-summary-mode)
- (addrbook-summary-display)
- (setq buffer-read-only t)
- (setq addrbook-summary-buffer buffer)
- buffer)))
-
-(defun addrbook-summary ()
- "Open the addressbook and show the summary window"
- (let ((buffer (get-buffer addrbook-summary-buffer-name)))
- (when (not buffer)
- (setq buffer (addrbook-make-summary-buffer)))
- (switch-to-buffer-other-window addrbook-summary-buffer)
- (addrbook-summary-goto-contact 0 t)))
-
-(defun addrbook-summarize ()
- "Summarize the contents of the addressbook in a summary buffer.
-
-The format is as described in the variable `addrbook-summary-format'"
- (interactive)
- (if (not (get-buffer addrbook-summary-buffer-name))
- (save-excursion
- (addrbook-get-create-summary-buffer)
- (set-buffer (get-buffer addrbook-summary-buffer-name))
- (addrbook-summary-goto-contact addrbook-current-card nil)))
- (addrbook-show-summary))
-
-(defun addrbook-show-summary ()
- (let ((buffer (get-buffer addrbook-summary-buffer-name)))
- (if addrbook-use-multiple-frames
- (switch-to-buffer-other-window buffer)
- (switch-to-buffer buffer))
- (addrbook-summary-goto-contact addrbook-current-card nil)))
-
-(defun addrbook-get-create-summary-buffer ()
- (if (not addrbook-summary-buffer)
- (save-excursion
- (setq addrbook-summary-buffer (get-buffer-create
addrbook-summary-buffer-name))
- (set-buffer addrbook-summary-buffer)
- (addrbook-summary-mode)
- (addrbook-summary-display)))
- addrbook-summary-buffer)
-
-;;;; ** Display functions
-
-(defun addrbook-summary-display ()
- (erase-buffer)
- (let (card-index card name)
- (dotimes (card-index (length addrbook-cards))
- (insert " ")
- (insert " ")
- (insert (propertize (number-to-string (+ card-index 1))
- 'face 'addrbook-summary-card-number)
- " ")
- (insert (make-string (- 4 (length (number-to-string card-index))) ?\ ))
- (setq card (addrbook-get-card card-index))
- (setq name (vcard-get-named-attribute card "n"))
- (insert (propertize (addrbook-get-card-fn t card-index)
- 'face 'addrbook-attribute-value))
- (add-text-properties (line-beginning-position)
- (line-end-position)
- (list 'card-index card-index))
- (insert (propertize "\n"
- 'card-index card-index)))))
-
-(defun addrbook-summary-goto-contact (numcard update-contact-buffer)
- (let (new-pos temp-new-pos found)
- (remove-overlays (point-min) (point-max))
- (if (equal (get-text-property (point-min) 'card-index) numcard)
- (setq new-pos (point-min))
- (setq temp-new-pos (point-min))
- (while (and (not found)
- (setq temp-new-pos (next-single-property-change temp-new-pos
'card-index)))
- (when (equal (get-text-property temp-new-pos 'card-index) numcard)
- (setq new-pos temp-new-pos)
- (setq found t))))
- (when new-pos
- (goto-char new-pos)
- (beginning-of-line)
- (let ((highlight-overlay (make-overlay (line-beginning-position)
- (line-beginning-position 2))))
- (overlay-put highlight-overlay 'face 'addrbook-summary-selected-card))
- (addrbook-summary-set-mode-line (+ numcard 1) (length addrbook-cards))
- (when (and update-contact-buffer
- (get-buffer addrbook-contact-buffer-name))
- (save-excursion
- (set-buffer (get-buffer addrbook-contact-buffer-name))
- (let (buffer-read-only)
- (addrbook-contact-display-card numcard)))))))
-
-(defun addrbook-summary-get-current-card ()
- (get-text-property (point) 'card-index))
-
-;;;; ** Commands
-
-(defun addrbook-summary-next-contact ()
- "Select the next card in the summary buffer"
- (interactive)
- (let ((card-index (addrbook-summary-get-current-card)))
- (cond
- ((equal card-index (- (length addrbook-cards) 1))
- (addrbook-summary-goto-contact 0 t))
- (t
- (addrbook-summary-goto-contact (+ card-index 1) t)))))
-
-(defun addrbook-summary-previous-contact ()
- "Select the previous card in the summary buffer"
- (interactive)
- (let ((card-index (addrbook-summary-get-current-card)))
- (cond
- ((equal card-index 0)
- (addrbook-summary-goto-contact (- (length addrbook-cards) 1) t))
- (t
- (addrbook-summary-goto-contact (- card-index 1) t)))))
-
-(defun addrbook-summary-show-contact ()
- "Open an addressbook buffer to show the current selected card"
- (interactive)
- (let ((card-index (addrbook-summary-get-current-card)))
- (when (not (get-buffer addrbook-contact-buffer-name))
- (save-excursion
- (addrbook-create-contact-buffer)
- (addrbook-contact-display-card card-index)
- (setq buffer-read-only t)))
- (addrbook-show-contact)))
-
-;; Modeline management
-
-(defun addrbook-summary-set-mode-line (card-number total-cards)
- "Update the mdoeline of the current summary buffer"
- ;; FIXME: this is ugly
- (when addrbook-summary-mode-line-string
- (setq mode-line-buffer-identification
- (list 24
- addrbook-summary-mode-line-string
- ": "
- (list 10
- (format "%d/%d" card-number total-cards))))))
-
-;;;; ** Major mode
-
-(defun addrbook-summary-mode ()
- "A major mode for the addressbook summary window
-
-Commands:
-\\{addrbook-summary-mode-map}"
- (interactive)
- (kill-all-local-variables)
- (setq addrbook-summary-mode-map (make-keymap))
- (define-key addrbook-summary-mode-map "n" 'addrbook-summary-next-contact)
- (define-key addrbook-summary-mode-map "p" 'addrbook-summary-previous-contact)
- (define-key addrbook-summary-mode-map (kbd "<down>")
'addrbook-summary-next-contact)
- (define-key addrbook-summary-mode-map (kbd "<up>")
'addrbook-summary-previous-contact)
- (define-key addrbook-summary-mode-map (kbd "RET")
'addrbook-summary-show-contact)
- (define-key addrbook-summary-mode-map "b" 'addrbook-bury)
- (define-key addrbook-summary-mode-map "q" 'addrbook-quit)
- (define-key addrbook-summary-mode-map "a" 'addrbook-create-card)
- (define-key addrbook-summary-mode-map "i" 'addrbook-import-vcard)
- (define-key addrbook-summary-mode-map "x" 'addrbook-export-vcard)
- (define-key addrbook-summary-mode-map "m" 'addrbook-send-email)
- (use-local-map addrbook-summary-mode-map)
- (setq mode-name "AddressBook Summary")
- (setq major-mode 'addrbook-summary-mode))
-
-;;;; * General commands (usable from all addressbook modes)
-
-(defun addrbook-send-email ()
- "Send an email to current contact"
- (interactive)
- (let* ((card (addrbook-get-card addrbook-current-card))
- (mail-addresses (vcard-ref card (list "email")))
- mail-names name i attr sendto-address letter)
- (dotimes (i (length mail-addresses))
- (let* ((attr (nth i mail-addresses))
- (attr-type (car (vcard-attr-get-parameter attr "type"))))
- (if (equal attr-type "internet")
- (setq mail-names (cons (list (car (vcard-attr-get-values attr))
- (+ ?a i))
- mail-names)))))
- (setq mail-names (reverse mail-names))
- (if (not mail-names)
- (message "Contact doesnt have a suitable smtp address")
- (if (equal (length mail-names) 1)
- (setq sendto-address (car (car mail-names)))
- (setq letter (addrbook-fast-selection mail-names "Select email address
to send mail to"))
- (dolist (name mail-names)
- (if (equal letter
- (cadr name))
- (setq sendto-address (car name)))))
- ;; Send the email
- (if sendto-address
- (compose-mail-other-frame (concat
- "\"" (addrbook-get-card-fn) "\""
- " <" sendto-address ">"))))))
-
-(defun addrbook-delete-card ()
- "Delete the current card"
- (interactive)
- (let ((buffer-read-only nil)
- (current-card addrbook-current-card)
- (prompt "Are you sure you want to delete current contact? "))
- (when (yes-or-no-p prompt)
- (if (equal current-card (- (length addrbook-cards) 1))
- (setq current-card (- (length addrbook-cards) 2)))
- (addrbook-remove-card addrbook-current-card)
- (add-to-list 'addrbook-modified-cards current-card)
- (if (equal (length addrbook-cards) 0)
- (addrbook-quit)
- (addrbook-contact-display-card current-card)))))
-
-(defun addrbook-create-card ()
- "Create a new card"
- (interactive)
- (let ((buffer-read-only nil)
- (new-card-index (addrbook-create-card-2)))
- (if new-card-index
- (addrbook-contact-display-card new-card-index))))
-
-(defun addrbook-create-card-2 ()
- "Create a new card with minimum identification properties and insert it
-into `addrbook-cards'.
-
-Return the index position of the new card"
- (let* (new-card
- (n-surname (read-from-minibuffer "Surname: "))
- (n-first-name (read-from-minibuffer "First name: "))
- (n-aka (read-from-minibuffer "AKA: "))
- (n-name-prefix (read-from-minibuffer "Name prefix: "))
- (n-name-suffix (read-from-minibuffer "Name suffix: "))
- (no-values (and (equal n-surname "")
- (equal n-first-name "")
- (equal n-aka "")
- (equal n-name-prefix "")
- (equal n-name-suffix "")))
- (new-card-index (length addrbook-cards)))
- (if no-values
- (progn
- (message "Contact not created")
- nil)
- ;; Create a new card
- (setq new-card (vcard-add-attribute new-card
- (cons (list "n")
- (list n-surname
- n-first-name
- n-aka
- n-name-prefix
- n-name-suffix))))
- (addrbook-set-card new-card-index new-card)
- (add-to-list 'addrbook-modified-cards new-card-index)
- new-card-index)))
-
-(defun addrbook-import-vcard (filename)
- "Import vCard from FILENAME and add it into our contact database and return
index card number."
- (interactive
- (list
- (expand-file-name
- (read-file-name "vCard file to import: "))))
-
- (let ((index nil)
- vcard)
- (addrbook-be-read-cards)
- (save-excursion
- (unwind-protect
- (if (and (setq index (length addrbook-cards))
- (setq vcard (vcard-parse-file filename)))
- (progn
- (addrbook-set-card index (car vcard))
- (add-to-list 'addrbook-modified-cards index))
- (error "Vcard import failed!"))
- ;; Just to be sure, call save-cards
- (addrbook-save-cards nil)))
- index))
-
-;; FIXME: does not work in contact mode
-(defun addrbook-export-vcard ()
- "Export current card data to a file."
- (interactive)
- (let* ((index (addrbook-summary-get-current-card))
- (fullname (addrbook-get-card-fn nil index ))
- (filename (read-file-name "Export vCard to file: " nil nil
- nil (concat fullname ".vcf"))))
- (addrbook-write-data-1 filename (addrbook-get-card index))
- (message "vCard exported")))
-
-(defun addrbook-write-data-1 (filename &optional vcard)
- "Save raw vCard formatted data into FILENAME.
-If optional VCARD parameter is not set, use `addrbook-current-card'."
- (let ((vcard (or vcard (addrbook-get-card addrbook-current-card))))
- (with-temp-file filename
- (vcard-insert vcard))))
-
-(defun addrbook-send-email ()
- "Send an email to current contact"
- (interactive)
- (let* ((card (addrbook-get-card addrbook-current-card))
- (mail-addresses (vcard-ref card (list "email")))
- mail-names name i attr sendto-address letter)
- (dotimes (i (length mail-addresses))
- (let* ((attr (nth i mail-addresses))
- (attr-type (car (vcard-attr-get-parameter attr "type"))))
- (if (equal attr-type "internet")
- (setq mail-names (cons (list (car (vcard-attr-get-values attr))
- (+ ?a i))
- mail-names)))))
- (setq mail-names (reverse mail-names))
- (if (not mail-names)
- (message "Contact doesnt have a suitable smtp address")
- (if (equal (length mail-names) 1)
- (setq sendto-address (car (car mail-names)))
- (setq letter (addrbook-fast-selection mail-names "Select email address
to send mail to"))
- (dolist (name mail-names)
- (if (equal letter
- (cadr name))
- (setq sendto-address (car name)))))
- ;; Send the email
- (if sendto-address
- (compose-mail-other-frame (concat
- "\"" (addrbook-get-card-fn) "\""
- " <" sendto-address ">"))))))
-
-(defun addrbook-save-cards (prefix)
- "Save cards into addrbook-file"
- (interactive "P")
- (if prefix
- (addrbook-export-card)
- ;; Save modified cards into addressbook-file
- (if (equal (length addrbook-modified-cards) 0)
- (message "addressbook not saved")
- (let ((i 0))
- (dotimes (i (length addrbook-cards))
- (when (member i addrbook-modified-cards)
- (addrbook-be-write-card i))))
- (setq addrbook-modified-cards nil)
- (set-buffer-modified-p nil)
- (message "addressbook saved"))))
-
-(defun addrbook-next-contact ()
- "Display the next card"
- (interactive)
- (let (buffer-read-only window-list win)
- (if (equal addrbook-current-card (- (length addrbook-cards) 1))
- (message "No more cards")
- (addrbook-contact-display-card (+ addrbook-current-card 1))
- (let ((summary-buffer (get-buffer addrbook-summary-buffer)))
- (when summary-buffer
- (setq window-list (get-buffer-window-list summary-buffer nil t))
- (dolist (win window-list)
- (with-selected-window (get-buffer-window summary-buffer t)
- (addrbook-summary-goto-contact addrbook-current-card nil))))))))
-
-(defun addrbook-previous-contact ()
- "Display the previous card"
- (interactive)
- (let (buffer-read-only)
- (if (equal addrbook-current-card 0)
- (message "First card")
- (addrbook-contact-display-card (- addrbook-current-card 1))
- (let ((summary-buffer (get-buffer addrbook-summary-buffer)))
- (when summary-buffer
- (setq window-list (get-buffer-window-list summary-buffer nil t))
- (dolist (win window-list)
- (with-selected-window (get-buffer-window summary-buffer t)
- (addrbook-summary-goto-contact addrbook-current-card nil))))))))
-
-(defun addrbook-quit ()
- "Exit the addressbook."
- (interactive)
- (if (and (not (equal (length addrbook-modified-cards) 0))
- (yes-or-no-p "Save addressbook? "))
- (addrbook-save-cards nil))
- (let ((contact-buffer (get-buffer addrbook-contact-buffer-name))
- (summary-buffer (get-buffer addrbook-summary-buffer-name))
- win window-list)
- (when summary-buffer
- ;; Delete windows (and possibly frames)
- (delete-windows-on summary-buffer)
- (kill-buffer summary-buffer))
- (when contact-buffer
- ;; Delete windows (and possibly frames)
- (delete-windows-on contact-buffer)
- (kill-buffer contact-buffer))))
-
-(defun addrbook-bury ()
- "Bury the addressbook buffer(s)."
- (interactive)
- (when (or (eq major-mode 'addrbook-summary-mode)
- (eq major-mode 'addrbook-contact-mode ))
- (bury-buffer)))
-
-(defun addrbook-export-card ()
- "Export current card data to a file"
- (interactive)
- (let ((filename (read-file-name "Export vCard to file: "))
- (card (addrbook-get-card addrbook-current-card)))
- (with-temp-file filename
- (vcard-insert card))
- (message "vCard exported")))
-
-;;;; * Backend management
-
-;;;; ** Customization and Variables
-
-(defcustom addrbook-backend
- 'addrbook-backend-simple
- "Backend to use for the addressbook.
-
-Currently there are two backends available: `addrbook-backend-simple' (simple
backend
-to store all contacts in one file) and `addrbook-backend-multiple' (that
stores one contact per file in
-a given directory"
- :type 'symbol)
-
-;;;; ** Utility functions
-
-(defun addrbook-make-params-explicit ()
- "Make unambiguous anonymous params explicit.
-
-It uses `addrbook-general-params' and the type parameter for each property
-defined in `addrbook-properties'"
- (let ((i 0))
- (dolist (card addrbook-cards)
- (dotimes (i (vcard-get-num-attributes card))
- (let* ((attr (vcard-get-attribute card i))
- (attr-name (vcard-attr-get-name attr))
- (attr-props (cdr (vcard-attr-get-proplist attr)))
- (property (addrbook-get-property attr-name))
- param
- (j 0))
- (dotimes (j (length attr-props))
- (let* ((param (nth j attr-props))
- (param-name (if (and param
- (listp param))
- (car param)
- nil))
- (param-value (if (and param
- (listp param))
- (cdr param)
- param)))
- ;; Search the param name in general-value
- (if (not param-name)
- (let* ((general-param (assoc param-value
addrbook-general-params))
- (general-param-name (if general-param (cadr
general-param)))
- (prop-types (addrbook-get-prop-parameter property
"type")))
- (if general-param-name
- (setq param-name general-param-name)
- (if (and prop-types
- (assoc param-value prop-types))
- (setq param-name "type")))
- (if param-name
- (setcar (nthcdr j attr-props) (cons param-name
param-value))))))))))))
-
-;;;; ** API
-
-(defun addrbook-be-read-cards ()
- "Read cards from an addressbook backend.
-
-This function stores the retrieved vCard information in
-`addrbook-cards'."
- (cond
- ((equal addrbook-backend 'addrbook-backend-simple)
- (addrbook-be-simple-read-cards))
- ((equal addrbook-backend 'addrbook-backend-multiple)
- (addrbook-be-multiple-read-cards))
- (t
- (error "No valid addressbook backend selected.")))
- (when addrbook-cards
- (addrbook-make-params-explicit)
- t))
-
-(defun addrbook-be-write-card (card-id)
- "Write the CARD-ID card to the appropiate backend."
- (cond
- ((equal addrbook-backend 'addrbook-backend-simple)
- (addrbook-be-simple-write-card card-id))
- ((equal addrbook-backend 'addrbook-backend-multiple)
- (addrbook-be-multiple-write-card card-id))
- (t
- (error "No valid addressbook backend selected."))))
-
-(defun addrbook-be-delete-card (card-id)
- "Delete the CARD-ID card from the appropiate backend."
- (cond
- ((equal addrbook-backend 'addrbook-backend-simple)
- (addrbook-be-simple-delete-card card-id))
- ((equal addrbook-backend 'addrbook-backend-multiple)
- (addrbook-be-multiple-delete-card card-id))
- (t
- (error "No valid addressbook backend selected."))))
-
-;;;; ** Simple backend
-
-(defcustom addrbook-file "~/.addressbook"
- "File with stored addresses"
- :type 'file
- :group 'addrbook)
-
-(defun addrbook-be-simple-read-cards ()
- "Read cards from addressbook file"
- (with-temp-buffer
- (insert-file-contents addrbook-file)
- (setq addrbook-cards (vcard-parse-region (point-min)
- (point-max)))))
-
-(defun addrbook-be-simple-write-card (card-id)
- "Write cards information to `addrbook-file', discarding any
-previous content."
- (with-temp-file addrbook-file
- (dotimes (i (length addrbook-cards))
- (let ((card (addrbook-get-card i)))
- (vcard-insert card)
- (if (not (equal i (- (length addrbook-cards) 1)))
- (insert "\n\n"))))))
-
-;;;; * Utility functions
-
-(defun addrbook-list-to-csv (list)
- (let ((result "")
- i)
- (dotimes (i (length list))
- (setq result (concat result (nth i list)))
- (if (not (equal i (- (length list) 1)))
- (setq result (concat result ","))))
- result))
-
-(defun addrbook-open ()
- "Open the addressbook"
- (or (addrbook-be-read-cards)
- (addrbook-create-card-2)))
-
-(defun addrbook-get-text-property-line (prop)
- "Return the value of text property PROP in the nearest position on current
line
-that has PROP defined as a text property"
- (let ((current-point (get-text-property (point) prop))
- (next-point-with-prop (next-single-property-change
- (point) prop nil (line-end-position)))
- (previous-point-with-prop (previous-single-property-change
- (point) prop nil
(line-beginning-position))))
- (or current-point
- (if next-point-with-prop
- (get-text-property next-point-with-prop prop)
- (get-text-property previous-point-with-prop prop)))))
-
-(defun addrbook-erase-tagged-region (tag)
- "Erase the region tagged with the same TAG value"
- (let ((begin-pos (previous-single-property-change (point) tag))
- (end-pos (next-single-property-change (point) tag)))
- (if (equal (point) (point-min))
- (setq begin-pos (point-min))
- (if (not (equal (get-text-property (point) tag)
- (get-text-property (- (point) 1) tag)))
- (setq begin-pos (point))))
- (if (equal (point) (point-max))
- (setq end-pos (point-max))
- (if (not (equal (get-text-property (point) tag)
- (get-text-property (+ (point) 1) tag)))
- (setq end-pos (+ point 1))))
- (cond ((and begin-pos end-pos)
- (delete-region begin-pos end-pos))
- ((and begin-pos (not end-pos))
- (delete-region begin-pos (point-max)))
- ((and (not begin-pos) end-pos)
- (delete-region (point-min) end-pos)))))
-
-(defun addrbook-sort-cards ()
- "Sort `addrbook-cards' using the `addrbook-field-for-sort' field"
- (setq addrbook-cards
- (sort addrbook-cards
- (lambda (card1 card2)
- (let* ((card1-n (vcard-get-named-attribute card1 "n"))
- (card2-n (vcard-get-named-attribute card2 "n"))
- (n-prop (addrbook-get-property "n"))
- (n-fields (addrbook-get-prop-fields n-prop))
- (field-index (addrbook-get-prop-index n-fields
addrbook-field-for-sort))
- (card1-n-field (nth field-index (vcard-attr-get-values
card1-n)))
- (card2-n-field (nth field-index (vcard-attr-get-values
card2-n))))
- (cond
- ((and (null card1-n-field) (not (null card2-n-field)))
- t)
- ((and (not (null card1-n-field)) (null card2-n-field))
- nil)
- ((and (null card1-n-field) (null card2-n-field))
- t)
- (t
- (string-lessp card1-n-field card2-n-field))))))))
-
-;;;; * Fast selection
-
-(defun addrbook-fast-selection (names prompt)
- "Fast group tag selection with single keys.
-
-NAMES is an association list of the form:
-
- ((\"NAME1\" char1) ...)
-
-Each character should identify only one name."
- ;; Adapted from `org-fast-tag-selection' in org.el by Carsten Dominic
- ;; Thanks Carsten! ;P
- (let* ((maxlen (apply 'max (mapcar (lambda (name)
- (string-width (car name))) names)))
- (buf (current-buffer))
- (fwidth (+ maxlen 3 1 3))
- (ncol (/ (- (window-width) 4) fwidth))
- name count result char i key-list)
- (save-window-excursion
- (set-buffer (get-buffer-create " *AddrBook Groups*"))
- (delete-other-windows)
- (split-window-vertically)
- (switch-to-buffer-other-window (get-buffer-create " *AddrBook Groups*"))
- (erase-buffer)
- (insert prompt ":")
- (insert "\n\n")
- (setq count 0)
- (while (setq name (pop names))
- (setq key-list (cons (cadr name) key-list))
- (insert "[" (cadr name) "] "
- (car name)
- (make-string (- fwidth 4 (length (car name))) ?\ ))
- (when (= (setq count (+ count 1)) ncol)
- (insert "\n")
- (setq count 0)))
- (goto-char (point-min))
- (if (fboundp 'fit-window-to-buffer)
- (fit-window-to-buffer))
- (catch 'exit
- (while t
- (message "[a-z0-9...]: Select entry [RET]: Exit")
- (setq char (let ((inhibit-quit t)) (read-char-exclusive)))
- (cond
- ((= char ?\r)
- (setq result nil)
- (throw 'exit t))
- ((member char key-list)
- (setq result char)
- (throw 'exit t)))))
- result)))
-
-(defun addrbook-select-type (attr-name)
- (let* ((property (addrbook-get-property attr-name))
- (prop-types (addrbook-get-prop-parameter property "type")))
- (let (type-names type letter result)
- (dolist (type prop-types)
- (setq type-names
- (cons (cdr type) type-names)))
- (setq type-names (reverse type-names))
- (setq letter (addrbook-fast-selection type-names "Select attribute
type"))
- (if letter
- (dolist (type type-names)
- (if (equal letter
- (cadr type))
- (setq result (car type)))))
- result)))
-
-(defun addrbook-select-non-existing-type (attr)
- (let* ((attr-name (vcard-attr-get-name attr))
- (property (addrbook-get-property attr-name))
- (prop-types (addrbook-get-prop-parameter property "type"))
- (attr-types (vcard-attr-get-parameter attr "type")))
- (let (type-names type letter result)
- (dolist (type prop-types)
- (if (not (member (car type) attr-types))
- (setq type-names
- (cons (cdr type) type-names))))
- (setq type-names (reverse type-names))
- (setq letter (addrbook-fast-selection type-names "Select attribute
type"))
- (if letter
- (dolist (type type-names)
- (if (equal letter
- (cadr type))
- (setq result (car type)))))
- result)))
-
-(defun addrbook-select-existing-type (attr)
- (let* ((attr-name (vcard-attr-get-name attr))
- (property (addrbook-get-property attr-name))
- (prop-types (addrbook-get-prop-parameter property "type"))
- (attr-types (vcard-attr-get-parameter attr "type")))
- (let (type-names type letter result)
- (dolist (type prop-types)
- (if (member (car type) attr-types)
- (setq type-names
- (cons (cdr type) type-names))))
- (setq type-names (reverse type-names))
- (setq letter (addrbook-fast-selection type-names "Select attribute
type"))
- (if letter
- (dolist (type type-names)
- (if (equal letter
- (cadr type))
- (setq result (car type)))))
- result)))
-
-(defun addrbook-select-group ()
- "Select a group interactively and return its symbol"
- (let (names group group-elt letter result)
- ;; Build the names list
- (dolist (group-elt addrbook-properties)
- (setq names
- (cons (list (addrbook-get-group-name group-elt)
- (addrbook-get-group-letter group-elt))
- names)))
- (setq names (reverse names))
- ;; Call the fast menu function to get the desired group
- (setq letter (addrbook-fast-selection names "Select group"))
- (dolist (group-elt addrbook-properties)
- (if (and (addrbook-get-group-letter group-elt)
- (equal letter (addrbook-get-group-letter group-elt)))
- (setq result (addrbook-get-group-symbol group-elt))))
- result))
-
-(defun addrbook-select-property (group-symbol)
- "Select a property interactively from GROUP and return its name"
- (let* ((group (addrbook-get-group group-symbol))
- (group-props (addrbook-get-group-props group))
- names attr attr-elt letter result)
- ;; Build the names list
- (dolist (prop group-props)
- (if (and (not (member (addrbook-get-prop-name prop)
addrbook-required-attrs))
- (addrbook-get-prop-letter prop))
- (setq names
- (cons (list (addrbook-get-prop-title prop)
- (addrbook-get-prop-letter prop))
- names))))
- (setq names (reverse names))
- ;; Call the fast menu function to get the desired group
- (setq letter (addrbook-fast-selection names "Select property"))
- (dolist (prop group-props)
- (if (and (addrbook-get-prop-letter prop)
- (equal letter (addrbook-get-prop-letter prop)))
- (setq result (addrbook-get-prop-name prop))))
- result))
-
-(defun addrbook-select-field (group-symbol prop-name)
- "Select a field interactively from PROP-NAME"
- (let* ((group (addrbook-get-group group-symbol))
- (group-props (addrbook-get-group-props group))
- (property (assoc prop-name group-props))
- (prop-fields (addrbook-get-prop-fields-list property))
- letter field result i)
- (setq letter (addrbook-fast-selection prop-fields "Select property field"))
- (dotimes (i (length prop-fields))
- (setq field (nth i prop-fields))
- (if (equal letter (addrbook-get-prop-field-letter field))
- (setq result i)))
- result))
-
-;;;; ** Search functions
-
-(defun addrbook-attr-matches-p (attr regexp)
- (let (result value
- (attr-values (vcard-attr-get-values attr)))
- (if (listp attr-values)
- (dolist (value attr-values)
- (if (string-match regexp value)
- (setq result t)))
- (setq result (string-match regexp attr-values)))
- result))
-
-(defun addrbook-search-cards (regexp &optional properties)
- "Search for REGEXP in card data and return a list with the indexes
-of matching cards.
-
-PROPERTIES is a list of property names.
-If PROPERTIES is specified and non-nil, the search is performed only in those
-attributes."
- (let (card prop attr card-index attr-index result)
- (dotimes (card-index (length addrbook-cards))
- (setq card (addrbook-get-card card-index))
- (dotimes (attr-index (vcard-get-num-attributes card))
- (setq attr (vcard-get-attribute card attr-index))
- (if (and (or (not properties)
- (member (vcard-attr-get-name attr) properties))
- (addrbook-attr-matches-p attr regexp))
- (add-to-list 'result card-index))))
- (reverse result)))
-
-;;;; * Entry points to the addressbook
-
-;;;###autoload
-(defun addressbook ()
- "Open the addressbook"
- (interactive)
- (if (and addrbook-force-addressbook-creation
- (not (file-exists-p addrbook-file)))
- (with-temp-file addrbook-file))
- (catch 'exit
- (let ((buffer (get-buffer addrbook-contact-buffer-name)))
- (if (not buffer)
- (let ((show-card-index 0)
- (user-input (if addrbook-ask-for-search
- (read-from-minibuffer "Search for contact [RET
goes to the summary]: ")
- "")))
- (unless (addrbook-open)
- (throw 'exit t))
- (addrbook-sort-cards)
- (if (not (equal user-input ""))
- (let ((found-cards (addrbook-search-cards user-input)))
- (if found-cards
- (setq show-card-index (car found-cards))
- (message "No contacts found")
- (throw 'exit t))
- ;; Goto the first card with matched data
- (addrbook-create-contact-buffer)
- (addrbook-contact-display-card show-card-index)
- (setq addrbook-modified-cards nil)
- (switch-to-buffer-other-window (get-buffer
addrbook-contact-buffer-name))
- (setq buffer-read-only t)
- (setq addrbook-buffer buffer))
- ;; Goto the summary
- (addrbook-summary))))
- (addrbook-show-summary))))
-
-
-;;;###autoload
-(defun addressbook-create ()
- "Create a new contact into the addressbook and save it"
- (interactive)
- (addrbook-be-read-cards)
- (let ((new-card-index (addrbook-create-card-2)))
- (if new-card-index
- (addrbook-save-cards nil))))
-
-
-(provide 'addressbook)
-
-;;; addrbook.el ends here
Index: addressbook.texi
===================================================================
RCS file: addressbook.texi
diff -N addressbook.texi
--- addressbook.texi 4 May 2007 22:20:03 -0000 1.1.1.1
+++ /dev/null 1 Jan 1970 00:00:00 -0000
@@ -1,140 +0,0 @@
-\input texinfo
address@hidden %**start of header
address@hidden addressbook.info
address@hidden Addressbook Manual
-
address@hidden VERSION 0.1
address@hidden DATE May 2007
-
address@hidden Emacs
address@hidden
-* Addressbook: (addressbook). Simple addressbook for Emacs
address@hidden direntry
-
address@hidden Version and Contact Info
address@hidden MAINTAINERSITE
@uref{http://www.emacswiki.org/cgi-bin/wiki/AddressBook}
address@hidden AUTHOR Jose E. Marchesi
address@hidden MAINTAINER Jose E. Marchesi
address@hidden MAINTAINEREMAIL @email{jemarch at gnu dot org}
address@hidden MAINTAINERCONTACT @uref{mailto:jemarch at gnu dot org, contact
the maintainer}
address@hidden %**end of header
address@hidden
-
address@hidden
-This manual is for Addressbook (version @value{VERSION}).
-
-Copyright @copyright{} 2007 Jose E. Marchesi
-
address@hidden
-Permission is granted to copy, distribute and/or modify this document
-under the terms of the GNU Free Documentation License, Version 1.1 or
-any later version published by the Free Software Foundation; with no
-Invariant Sections.
address@hidden quotation
address@hidden copying
-
address@hidden
address@hidden Addressbook Manual
-
address@hidden Release @value{VERSION}
address@hidden by Jose E. Marchesi
-
address@hidden
address@hidden 0pt plus 1filll
address@hidden
address@hidden titlepage
-
address@hidden
-
address@hidden
-
address@hidden Top, Summary, (dir), (dir)
address@hidden Addressbook Manual
-
address@hidden
address@hidden ifnottex
-
address@hidden
-* Summary:: Brief summary of the
addressbook
-* Getting the program:: Downloading the addressbook
-* Installation:: How to install the adressbook
-* Configuration::
-* Contacts:: The addressbook stores data
about contacts
-* Accessing the addressbook::
-* Importing and exporting contact data::
address@hidden menu
-
address@hidden Summary, Getting the program, Top, Top
address@hidden Summary
-
-AddressBook is a simple vCard based addressbook for Emacs.
-
-It is similar to the insidious big brother database, but instead of
-using a custom format for data storage, it uses the standard vCard
-format to maintain contacts data.
-
address@hidden Getting the program, Installation, Summary, Top
address@hidden Getting the program
-
-You need the following files in order to run the addressbook:
-
address@hidden @bullet
address@hidden
-addressbook.el
address@hidden://es.gnu.org/~jemarch/downloads/addrbook/addressbook.el}
address@hidden
-A modified version of Noah Friedman's vcard.el
address@hidden://es.gnu.org/~jemarch/downloads/addrbook/vcard.el}
address@hidden itemize
-
-Note that since the addressbook is under heavy development and it has
-not released yet, those files may change (even several times in a
-day). You can use the CVS Id tag to determine if you are downloading a
-new version.
-
-
address@hidden Installation, Configuration, Getting the program, Top
address@hidden Installation
-
-Make @file{addrbook.el} and @file{vcard.el} loadable to your emacs (put the
-files in a directory contained in your @code{load-path}).
-
-You can customize the addressbook using the customize interface. If
-you dont like to use customize, take a look into the sources for
-interesting variables.
-
-The most important variable to set is @code{addrbook-file}, that contain
-the file where you store your contacts (a collection of vCards). It
-defaults to @file{~/.addressbook}.
-
address@hidden Configuration, Contacts, Installation, Top
address@hidden Configuration
-
address@hidden Contacts, Accessing the addressbook, Configuration, Top
address@hidden Contacts
-
-The addressbook manages a collection of contact data.
-
address@hidden Accessing the addressbook, Importing and exporting contact data,
Contacts, Top
address@hidden Accessing the addressbook
-
-There are several ways to access the addressbook:
-
address@hidden @bullet
address@hidden
-Opening the interactive interface calling the interactive function
@code{addressbook}
address@hidden
-Inserting a new contact without open the interactive interface calling
-the interactive function @code{addressbook-create}
address@hidden
-Using the addressbook API (see FIXME:)
address@hidden
-From any other application that uses the addressbook API (such as a MUA).
address@hidden itemize
-
-Next sections of this manual discuss the interactive interface.
-
address@hidden Importing and exporting contact data, , Accessing the
addressbook, Top
address@hidden Importing and exporting contact data
-
address@hidden
Index: uuid.el
===================================================================
RCS file: uuid.el
diff -N uuid.el
--- uuid.el 29 May 2007 23:11:41 -0000 1.1
+++ /dev/null 1 Jan 1970 00:00:00 -0000
@@ -1,484 +0,0 @@
-;;;; uuid.el --- Universal Unique Identifiers
-
-;; Copyright (C) 2007 Jose E. Marchesi
-
-;; Maintainer: Jose E. Marchesi
-;; Keywords: standards
-
-;; $Id: uuid.el,v 1.1 2007/05/29 23:11:41 jemarch Exp $
-
-;; This file is NOT part of GNU Emacs.
-
-;; This program is free software; you can redistribute it and/or modify
-;; it under the terms of the GNU General Public License as published by
-;; the Free Software Foundation; either version 2, or (at your option)
-;; any later version.
-
-;; This program is distributed in the hope that it will be useful,
-;; but WITHOUT ANY WARRANTY; without even the implied warranty of
-;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-;; GNU General Public License for more details.
-
-;; You should have received a copy of the GNU General Public License
-;; along with this program; see the file COPYING. If not, write to the
-;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
-;; Boston, MA 02110-1301, USA.
-
-;;;; Commentary
-
-;; This file contain an implementation of the ITU X.667 Recommendation
-;; for the generation of Universal Unique Identifiers (also known as
-;; Globally Unique Identifiers or GUIDs).
-;;
-;; Each UUID is a hexadecimal-coded ascii sequence composed by the
-;; following fields (separated by the ascii hypen-minus, 45 character,
-;; except between the VariantAndClockSeqHigh and ClockSeqLow):
-;;
-;; - TimeLow (4 octects => 8 hexadecimal digits)
-;; - TimeMid (2 octects => 4 hexadecimal digits)
-;; - VersionAndTimeHigh (2 octects => 4 hexadecimal digits)
-;; - VariantAndClockSeqHigh (1 octect => 2 hexadecimal digits)
-;; - ClockSeqLow (1 octect => 2 hexadecimal digits)
-;; - Node (6 octects => 12 hexadecimal digits)
-;;
-;; For example:
-;;
-;; 00000000-0000-0000-0000-000000000000
-;;
-;; There are three standarized ways to generate the values of those
-;; fields:
-;;
-;; - time-based
-;; - random-based
-;; - name-based
-;;
-;; You can specify the generation semantics to use via the optional
-;; `uuid-type' parameter to `uuid-generate'. The default method is the
-;; time-based one.
-;;
-;; Note that, according to the ITU recommendation, uuid generators
-;; should generate lower-case letters in hexadecimal encoding. On the
-;; other hand, it is recommended for uuid consumers to be
-;; case-insensitive regarding alphabetic characters in hex
-;; strings. This implementation follows both recommendations.
-
-;;;; Code:
-
-(require 'calc)
-
-(defgroup uuid nil
- "Universal Unique Identifiers"
- :group 'development
- :link '(url-link
"http://www.emacswiki.org/cgi-bin/wiki/UniversalUniqueIdentifiers";))
-
-(defcustom uuid-ifconfig-program
- "/sbin/ifconfig"
- "Location of the `ifconfig' program to determine the MAC
-address to use in the time-based method. If it is set to nil,
-then a standarized alternative random method is used."
- :group 'uuid)
-
-(defvar uuid-hexoctect-regexp
- "[0-9a-fA-F][0-9a-fA-F]"
- "Regexp that matches the hexadecimal representation of an octect using
lower-case letters")
-
-(defvar uuid-time-low-regexp
- (concat uuid-hexoctect-regexp
- uuid-hexoctect-regexp
- uuid-hexoctect-regexp
- uuid-hexoctect-regexp)
- "Regexp that matches the TimeLow field of a uuid")
-
-(defvar uuid-time-mid-regexp
- (concat uuid-hexoctect-regexp
- uuid-hexoctect-regexp)
- "Regexp that matches the TimeMid field of a uuid")
-
-(defvar uuid-version-and-time-high-regexp
- (concat uuid-hexoctect-regexp
- uuid-hexoctect-regexp)
- "Regexp that matches the VersionAndTimeHigh field of a uuid")
-
-(defvar uuid-variant-and-clock-seqhigh-regexp
- uuid-hexoctect-regexp
- "Regexp that matches the VariantAndClockSeqHigh field of a uuid")
-
-(defvar uuid-clock-seq-low-regexp
- uuid-hexoctect-regexp
- "Regexp that matches the ClockSeqLow field of a uuid")
-
-(defvar uuid-node-regexp
- (concat uuid-hexoctect-regexp
- uuid-hexoctect-regexp
- uuid-hexoctect-regexp
- uuid-hexoctect-regexp
- uuid-hexoctect-regexp
- uuid-hexoctect-regexp)
- "Regexp that matches the Node field of a uuid")
-
-(defvar uuid-regexp
- (concat "^"
- uuid-time-low-regexp
- "-"
- uuid-time-mid-regexp
- "-"
- uuid-version-and-time-high-regexp
- "-"
- uuid-variant-and-clock-seqhigh-regexp
- uuid-clock-seq-low-regexp
- "-"
- uuid-node-regexp
- "$")
- "Regexp that matches a uuid hexadecimal-coded value")
-
-(defvar uuid-time-based-version-hex
- "1"
- "Hexadecimal string encoding the time-based version of a uuid")
-
-(defvar uuid-dce-security-version-hex
- "2"
- "Hexadecimal string encoding the reserved DCE security version of a uuid")
-
-(defvar uuid-name-based-md5-version-hex
- "3"
- "Hexadecimal string encoding the name-based version with MD5 hash of a uuid")
-
-(defvar uuid-name-based-sha1-version-hex
- "4"
- "Hexadecimal string encoding the name-based version with SHA-1 hash of a
uuid")
-
-(defvar uuid-random-number-based-version-hex
- "5"
- "Hexadecimal string encoding the random-number-based version of a uuid")
-
-(defvar uuid-namespace-dns
- ;; 6BA7B810
- (list #x6BA7 #xB810
- #x9DAD
- #x11D1
- #x80B4 #x00C0 #x4FD4 #x30C8)
- "ITU X.667 recommended namespace for DNS names")
-
-(defvar uuid-namespace-url
- (list #x6BA7 #xB811
- #x9DAD
- #x11D1
- #x80B4 #x00C0 #x4FD4 #x30C8)
- "ITU X.667 recommended namespace for URL names")
-
-(defvar uuid-namespace-oid
- (list #x6BA7 #xB812
- #x9DAD
- #x11D1
- #x80B4 #x00C0 #x4FD4 #x30C8)
- "ITU X.667 recommended namespace for OID names")
-
-(defvar uuid-namespace-x500
- (list #x6BA7 #xB814
- #x9DAD
- #x11D1
- #x80B4 #x00C0 #x4FD4 #x30C8)
- "ITU X.667 recommended namespace for directory names")
-
-;;;###autoload
-(defun uuid-generate (&optional uuid-type namespace name)
- "Generate and return a new universal unique identifier according
-with the ITU X.667 Recommendation for the generation of Universal Unique
-Identifiers.
-
-If specified, UUID-TYPE identifies the desired uuid type: `time',
-`name-md5', `name-sha1' or `random'. It defaults to `time'.
-
-If specified and `name-md5' or `name-sha1' is used, NAMESPACE is
-the namespace to use (see `uuid-namespace-XXX' variables).
-
-If specified, NAME is the name for the `name-md5' or `name-sha1'
-method."
- (if (not uuid-type)
- (setq uuid-type 'time))
- (cond
- ((equal uuid-type 'time)
- (uuid-generate-time-based))
- ((or (equal uuid-type 'name-md5)
- (equal uuid-type 'name-sha1))
- (when (not (and namespace name))
- (error "You must specify values for both NAMESPACE and NAME"))
- (uuid-generate-name-based uuid-type namespace name))
- ((equal uuid-type 'random)
- (uuid-generate-random-based))
- (t
- (error "Wrong generation algorithm.\
- Valid ones are 'time 'name-md5 'name-sha1 or 'random"))))
-
-(defun uuid-generate-name-based (type namespace name)
- "Generate and return a name-based uuid."
- (let (time-low
- time-mid
- version-and-time-high
- clock-seq-low
- variant-and-clock-seq-high
- node
- hash
- (name-sequence "")
- i)
- ;; Convert the name to a canonical sequence of octets (as defined by the
standards or conventions of its
- ;; name space).
- (dotimes (i (length name))
- (setq name-sequence
- (concat name-sequence (format "%.2x" (aref name i)))))
- ;; Compute the 16-octet hash value of the name space identifier
- ;; concatenated with the name, using the hash function specified
- ;; in 14.2 or 14.3. The numbering of the octets in the hash value
- ;; is from 0 to 15, as specified in IETF RFC 1321 (for MD5) and as
- ;; specified in FIPS PUB 180-2 for SHA-1.
- (cond
- ((equal type 'name-sha1)
- (error "Name-based type method sha1 not implemented"))
- ((equal type 'name-md5)
- (setq hash (md5 (concat (uuid-namespace-to-string namespace)
- name-sequence))))
- (t
- (error "Wrong name-based type")))
-
- ;; Set octets 3 through 0 of the "TimeLow" field to octets 3
- ;; through 0 of the hash value.
- (setq time-low
- (concat (format "%.2x" 0)
- (substring hash 26)))
- ;; Set octets 1 and 0 of the "TimeMid" field to octets 5 and 4 of
- ;; the hash value.
- (setq time-mid
- (substring hash 22 25))
- ;; Set octets 1 and 0 of the "VersionAndTimeHigh" field to octets
- ;; 7 and 6 of the hash value.
-
- ;; Overwrite the four most significant bits (bits 15 through 12)
- ;; of the "VersionAndTimeHigh" field with the four-bit version
- ;; number from Table 3 of 12.2 for the hash function that was
- ;; used.
-
- ;; Set the "VariantAndClockSeqHigh" field to octet 8 of the hash
- ;; value.
-
- ;; Overwrite the two most significant bits (bits 7 and 6) of the
- ;; "VariantAndClockSeqHigh" field with 1 and 0, respectively.
-
- ;; Set the "ClockSeqLow" field to octet 9 of the hash value.
-
- ;; Set octets 5 through 0 of the "Node" field to octets 15 through
- ;; 10 of the hash value.
- (concat time-low "-"
- time-mid "-"
- version-and-time-high "-"
- variant-and-clock-seq-high
- clock-seq-low "-"
- node)))
-
-(defun uuid-generate-random-based ()
- "Generate and return a random-based uuid"
- (let (time-low
- time-mid
- version-and-time-high
- clock-seq-low
- variant-and-clock-seq-high
- node)
- ;; Set the two most significant bits (bits 7 and 6) of the
- ;; "VariantAndClockSeqHigh" field to 1 and 0, respectively.
- (setq variant-and-clock-seq-high
- (format "%.2x" (logior #x80 (logand #xBF (random (expt 2 8))))))
- ;; Set the four most significant bits (bits 15 through 12) of the
- ;; "VersionAndTimeHigh" field to the four-bit version number
- ;; specified in 12.2.
- (setq version-and-time-high
- (concat uuid-random-number-based-version-hex
- (format "%.3x" (random (expt 2 12)))))
- ;; Set all the other bits of the UUID to randomly (or
- ;; pseudo-randomly) generated values.
- (setq time-low
- (concat (format "%.4x" (random (expt 2 16)))
- (format "%.4x" (random (expt 2 16)))))
- (setq time-mid
- (format "%.4x" (random (expt 2 16))))
- (setq clock-seq-low
- (format "%.2x" (random (expt 2 8))))
- (setq node
- (concat
- (format "%.4x" (random (expt 2 16)))
- (format "%.4x" (random (expt 2 16)))
- (format "%.4x" (random (expt 2 16)))))
- (concat time-low "-"
- time-mid "-"
- version-and-time-high "-"
- variant-and-clock-seq-high
- clock-seq-low "-"
- node)))
-
-(defun uuid-generate-time-based ()
- "Generate and return a time-based uuid"
- ;; Determine the values for the UTC-based Time and the Clock
- ;; Sequence to be used in the UUID, as specified in 12.3 and 12.4.
- (let (time
- clock-sequence
- time-low time-mid version-and-time-high clock-seq-low
- variant-and-clock-seq-high
- node)
- ;; For the purposes of this algorithm, consider Time to be a
- ;; 60-bit unsigned integer and the Clock Sequence to be a 14-bit
- ;; unsigned integer.
- (setq time (uuid-generate-time))
- (setq clock-sequence (uuid-generate-clock-sequence))
- ;; Set the "TimeLow" field equal to the least significant 32 bits
- ;; (bits 31 through 0) of Time in the same order of significance.
- (setq time-low
- (concat
- (format "%.3x" (logand #x000FF (nth 1 time)))
- (format "%.5x" (nth 2 time))))
- ;; Set the "TimeMid" field equal to bits 47 through 32 from the
- ;; Time in the same order of significance.
- (setq time-mid
- (concat
- (format "%.2x" (logand #x0007F (nth 0 time)))
- (format "%.2x" (ash (nth 1 time) -12))))
-
- ;; Set the 12 least significant bits (bits 11 through 0) of the
- ;; "VersionAndTimeHigh" field equal to bits 59 through 48 from
- ;; Time in the same order of significance.
- ;; Set the four most significant bits (bits 15 through 12) of the
- ;; "VersionAndTimeHigh" field to the four-bit version number
- ;; specified in 12.2.
- (setq version-and-time-high
- (concat uuid-time-based-version-hex
- (format "%.3x" (ash (nth 0 time) -7))))
- ;; Set the "ClockSeqLow" field to the eight least significant bits
- ;; (bits 7 through 0) of the Clock Sequence in the same order of
- ;; significance.
- (setq clock-seq-low
- (format "%.2x" (logand #x000F clock-sequence)))
- ;; Set the six least significant bits (bits 5 through 0) of the
- ;; "VariantAndClockSeqHigh" field to the six most significant bits
- ;; (bits 13 through 8) of the Clock Sequence in the same order of
- ;; significance.
- ;; Set the two most significant bits (bits 7 and 6) of the
- ;; "VariantAndClockSeqHigh" clock to one and zero, respectively.
- (setq variant-and-clock-seq-high
- (format "%.2x" (logand #x00BF (ash clock-sequence -9))))
- ;; Set the node field to the 48-bit MAC address in the same order
- ;; of significance as the address.
- (let ((mac-address (uuid-get-mac-address)))
- (if mac-address
- (setq node (uuid-format-mac-address mac-address))
- ;; Use a random number
- (setq node
- (concat
- (format "%.4x" (random (expt 2 16)))
- (format "%.4x" (random (expt 2 16)))
- (format "%.4x" (random (expt 2 16)))))))
- (concat time-low "-"
- time-mid "-"
- version-and-time-high "-"
- variant-and-clock-seq-high
- clock-seq-low "-"
- node)))
-
-(defun uuid-generate-time ()
- "Return the number of 100 nanosecond intervals of UTC since the beginning
-of the Gregorian calendar (00:00:00, 15 October 1582).
-
-The returned value is a list:
-
- (TIME-HIGH TIME-MID TIME-LOW)
-
-with three 20-bits unsigned integers that conform a 60-bit
-unsigned integer.
-
-NOTE: we use a resolution of seconds in this code."
- ;; 100 ns intervals offset between Gregorian beginning (00:00:00, 15
- ;; October 1582) and the epoch (00:00:00, 1 January 1970):
- ;; 0x1B21DD213814000
-
- ;; Operate with 20-bit numbers (GNU Emacs assures integers are
- ;; at least 29 bits wide and 20/4 = 5)
- (let ((greg-epoch-offset-high #x1B21D)
- (greg-epoch-offset-mid #xD2138)
- (greg-epoch-offset-low #x14000)
- since-epoch-high since-epoch-mid since-epoch-low
- (current-time (current-time)))
- ;; Calculate time since the epoch in seconds
- (setq since-epoch-time-low (+ (nth 1 current-time)
- (logand #xF (nth 0 current-time))))
- (setq since-epoch-time-mid (ash (nth 0 current-time) -4))
- (setq since-epoch-time-high (ash (nth 2 current-time) -9))
- ;; TODO: since-epoch-time * 10.000.000
- ;; TODO: Finishme
- (list since-epoch-time-high
- since-epoch-time-mid
- since-epoch-time-low)))
-
-(defun uuid-generate-clock-sequence ()
- "Return a clock sequence number that should be interpreted
-as a 14-bit unsigned integer.
-
-NOTE: Since this implementation does not store any state, we
-follow the ITU recommendation in using a pseudo-random number
-that is _not_ derivated from the Node."
- (random (expt 2 14)))
-
-(defun uuid-format-mac-address (mac-addr)
- "Format MAC-ADDR (a valid MAC address) to a raw hex format"
- (downcase (replace-regexp-in-string ":" "" mac-addr)))
-
-(defun uuid-get-mac-address ()
- "Return a suitable MAC address from a network card in the host computer.
-If no MAC address is found, then return nil."
- (when (file-executable-p uuid-ifconfig-program)
- (save-excursion
- (with-temp-buffer
- (call-process uuid-ifconfig-program nil t nil "-a")
- (goto-char (point-min))
- (when (re-search-forward "HWaddr " nil t)
- (re-search-forward (concat uuid-hexoctect-regexp
- ":"
- uuid-hexoctect-regexp
- ":"
- uuid-hexoctect-regexp
- ":"
- uuid-hexoctect-regexp
- ":"
- uuid-hexoctect-regexp
- ":"
- uuid-hexoctect-regexp) nil t)
- (buffer-substring (match-beginning 0)
- (match-end 0)))))))
-
-(defun uuid-namespace-to-string (namespace)
- "Return the hex string representation of NAMESPACE"
- (concat
- (format "%.4x" (nth 0 namespace))
- (format "%.4x" (nth 1 namespace))
- (format "%.4x" (nth 2 namespace))
- (format "%.4x" (nth 3 namespace))
- (format "%.4x" (nth 4 namespace))
- (format "%.4x" (nth 5 namespace))
- (format "%.4x" (nth 6 namespace))
- (format "%.4x" (nth 7 namespace))))
-
-;;;###autoload
-(defun uuidp (uuid)
- "Return t if UUID is a valid uuid"
- (save-match-data
- (when (string-match uuid-regexp uuid)
- t)))
-
-;;;###autoload
-(defun uuid-lessp (uuid1 uuid2)
- "Return t if UUID1 is lesser than UUID2."
- (string-lessp uuid1 uuid2))
-
-;;;###autoload
-(defun uuid-equal (uuid1 uuid2)
- "Return t if UUID1 and UUID2 are the same uuid."
- (string-equal uuid1 uuid2))
-
-(provide 'uuid)
-
-;;; uuid.el ends here
Index: vcard.el
===================================================================
RCS file: vcard.el
diff -N vcard.el
--- vcard.el 31 May 2007 14:06:59 -0000 1.3
+++ /dev/null 1 Jan 1970 00:00:00 -0000
@@ -1,727 +0,0 @@
-;;; vcard.el --- vcard parsing routines
-
-;; Copyright (C) 1997, 1999, 2000 Noah S. Friedman
-;; Copyright (C) 2007 Jose E. Marchesi
-
-;; Author: Noah Friedman <address@hidden>
-;; Maintainer: address@hidden
-;; Keywords: vcard, mail, news
-;; Created: 1997-09-27
-
-;; $Id: vcard.el,v 1.3 2007/05/31 14:06:59 jemarch Exp $
-
-;; This program is free software; you can redistribute it and/or modify
-;; it under the terms of the GNU General Public License as published by
-;; the Free Software Foundation; either version 2, or (at your option)
-;; any later version.
-;;
-;; This program is distributed in the hope that it will be useful,
-;; but WITHOUT ANY WARRANTY; without even the implied warranty of
-;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-;; GNU General Public License for more details.
-;;
-;; You should have received a copy of the GNU General Public License
-;; along with this program; see the file COPYING. If not, write to the
-;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
-;; Boston, MA 02110-1301, USA.
-
-;;; Commentary:
-
-;; Unformatted vcards are just plain ugly. But if you live in the MIME
-;; world, they are a better way of exchanging contact information than
-;; freeform signatures since the former can be automatically parsed and
-;; stored in a searchable index.
-;;
-;; This library of routines provides the back end necessary for parsing
-;; vcards so that they can eventually go into an address book like BBDB
-;; (although this library does not implement that itself).
-
-;; This library does not interface directly with any mail user agents. For
-;; an example of bindings for the VM MUA, see vm-vcard.el available from
-;;
-;; http://www.splode.com/~friedman/software/emacs-lisp/index.html#mail
-;;
-;; Updates to vcard.el should be available there too.
-
-;; The vcard 2.1 format is defined by the versit consortium.
-;; See http://www.imc.org/pdi/vcard-21.ps
-;;
-;; RFC 2426 defines the vcard 3.0 format.
-;; See ftp://ftp.rfc-editor.org/in-notes/rfc2426.txt
-
-;; A parsed vcard is a list of attributes of the form
-;;
-;; (proplist value1 value2 ...)
-;;
-;; Where proplist is a list of property names and parameters, e.g.
-;;
-;; (property1 (property2 . parameter2) ...)
-;;
-;; Each property has an associated implicit or explicit parameter value
-;; (not to be confused with attribute values; in general this API uses
-;; `parameter' to refer to property values and `value' to refer to attribute
-;; values to avoid confusion). If a property has no explicit parameter value,
-;; the parameter value is considered to be `t'. Any property which does not
-;; exist for an attribute is considered to have a nil parameter.
-
-;; TODO:
-;; * Finish supporting the 3.0 extensions.
-;; Currently, only the 2.1 standard is supported.
-;; * Handle nested vcards and grouped attributes?
-;; (I've never actually seen one of these in use.)
-;; * Handle multibyte charsets.
-
-;;; Code:
-
-(defgroup vcard nil
- "Support for the vCard electronic business card format."
- :group 'vcard
- :group 'mail
- :group 'news)
-
-;;;###autoload
-(defcustom vcard-standard-filters
- '(vcard-filter-html
- vcard-filter-adr-newlines
- vcard-filter-tel-normalize
- vcard-filter-textprop-cr)
- "*Standard list of filters to apply to parsed vcard data.
-These filters are applied sequentially to vcard attributes when
-the function `vcard-standard-filter' is supplied as the second argument to
-`vcard-parse'."
- :type 'hook
- :group 'vcard)
-
-
-;;; No user-settable options below.
-
-;; XEmacs 21 ints and chars are disjoint types.
-;; For all else, treat them as the same.
-(defalias 'vcard-char-to-int
- (if (fboundp 'char-to-int) 'char-to-int 'identity))
-
-;; This is just the version number for this package; it does not refer to
-;; the vcard format specification. Currently, this package does not yet
-;; support the full vcard 3.0 specification.
-;;
-;; Whenever any part of the API defined in this package change in a way
-;; that is not backward-compatible, the major version number here should be
-;; incremented. Backward-compatible additions to the API should be
-;; indicated by increasing the minor version number.
-(defconst vcard-api-version "3.0")
-
-;; The vcard standards allow specifying the encoding for an attribute using
-;; these values as immediate property names, rather than parameters of the
-;; `encoding' property. If these are encountered while parsing, associate
-;; them as parameters of the `encoding' property in the returned structure.
-(defvar vcard-encoding-tags
- '("quoted-printable" "base64" "8bit" "7bit"))
-
-;; The vcard parser will auto-decode these encodings when they are
-;; encountered. These methods are invoked via vcard-parse-region-value.
-(defvar vcard-region-decoder-methods
- '(("quoted-printable" . vcard-region-decode-quoted-printable)
- ("base64" . vcard-region-decode-base64)))
-
-;; This is used by vcard-region-decode-base64
-(defvar vcard-region-decode-base64-table
- (let* ((a "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/")
- (len (length a))
- (tbl (make-vector 123 nil))
- (i 0))
- (while (< i len)
- (aset tbl (vcard-char-to-int (aref a i)) i)
- (setq i (1+ i)))
- tbl))
-
-(defvar vcard-regexp-begin-vcard "^begin:[ \t]*vcard[ \t]*\n"
- "Regexp to match the begin of a vcard")
-(defvar vcard-regexp-end-vcard "^end[ \t]*:[ \t]*vcard[ \t]*$"
- "Regexp to match the end of a vcard")
-
-
-;;; Parsing routines
-
-;;;###autoload
-(defun vcard-parse-string (raw &optional filter)
- "Parse RAW vcard data as a string, and return an alist representing data.
-
-If the optional function FILTER is specified, apply that filter to each
-attribute. If no filter is specified, `vcard-standard-filter' is used.
-
-Filters should accept two arguments: the property list and the value list.
-Modifying in place the property or value list will affect the resulting
-attribute in the vcard alist.
-
-Vcard data is normally in the form
-
- begin: vcard
- prop1a: value1a
- prop2a;prop2b;prop2c=param2c: value2a
- prop3a;prop3b: value3a;value3b;value3c
- end: vcard
-
-\(Whitespace around the `:' separating properties and values is optional.\)
-If supplied to this function an alist of the form
-
- \(\(\(\"prop1a\"\) \"value1a\"\)
- \(\(\"prop2a\" \"prop2b\" \(\"prop2c\" . \"param2c\"\)\) \"value2a\"\)
- \(\(\"prop3a\" \"prop3b\"\) \"value3a\" \"value3b\" \"value3c\"\)\)
-
-would be returned."
- (let ((vcard nil)
- (buf (generate-new-buffer " *vcard parser work*")))
- (unwind-protect
- (save-excursion
- (set-buffer buf)
- ;; Make sure last line is newline-terminated.
- ;; An extra trailing newline is harmless.
- (insert raw "\n")
- (setq vcard (vcard-parse-region (point-min) (point-max) filter)))
- (kill-buffer buf))
- vcard))
-
-;;;###autoload
-(defun vcard-parse-region (beg end &optional filter)
- "Parse the raw vcard data in region, and return an alist representing data.
-This function is just like `vcard-parse-string' except that it operates on
-a region of the current buffer rather than taking a string as an argument.
-
-Note: this function modifies the buffer!"
- (or filter
- (setq filter 'vcard-standard-filter))
- (let ((case-fold-search t)
- (vcard-list-data nil)
- (pos (make-marker))
- (newpos (make-marker))
- properties value)
- (save-restriction
- (narrow-to-region beg end)
- (save-match-data
- ;; Unfold folded lines and delete naked carriage returns
- (goto-char (point-min))
- (while (re-search-forward "\r$\\|\n[ \t]" nil t)
- (goto-char (match-beginning 0))
- (delete-char 1))
-
- (goto-char (point-min))
- (while (re-search-forward vcard-regexp-begin-vcard nil t)
- (let ((vcard-data nil))
- (set-marker pos (point))
- (while (and (not (looking-at vcard-regexp-end-vcard))
- (re-search-forward ":[ \t]*" nil t))
- (set-marker newpos (match-end 0))
- (setq properties
- (vcard-parse-region-properties pos (match-beginning 0)))
- (set-marker pos (marker-position newpos))
- (re-search-forward "[ \t]*\n")
- (set-marker newpos (match-end 0))
- (setq value
- (vcard-parse-region-value properties pos (match-beginning
0)))
- (set-marker pos (marker-position newpos))
- (goto-char pos)
- (funcall filter properties value)
- (setq vcard-data (cons (cons properties value) vcard-data)))
- (setq vcard-list-data (cons (nreverse vcard-data)
vcard-list-data))))))
- (nreverse vcard-list-data)))
-
-(defun vcard-parse-region-properties (beg end)
- (downcase-region beg end)
- (let* ((proplist (vcard-split-string (buffer-substring beg end) ";"))
- (props proplist)
- split)
- (save-match-data
- (while props
- (cond ((string-match "=" (car props))
- (setq split (vcard-split-string (car props) "=" 2))
- (setcar props (cons (car split) (car (cdr split)))))
- ((member (car props) vcard-encoding-tags)
- (setcar props (cons "encoding" (car props)))))
- (setq props (cdr props))))
- proplist))
-
-(defun vcard-parse-region-value (proplist beg end)
- (let* ((encoding (vcard-get-property proplist "encoding"))
- (decoder (cdr (assoc encoding vcard-region-decoder-methods)))
- result pos match-beg match-end)
- (save-restriction
- (narrow-to-region beg end)
- (cond (decoder
- ;; Each `;'-separated field needs to be decoded and saved
- ;; separately; if the entire region were decoded at once, we
- ;; would not be able to distinguish between the original `;'
- ;; chars and those which were encoded in order to quote them
- ;; against being treated as field separators.
- (goto-char beg)
- (setq pos (set-marker (make-marker) (point)))
- (setq match-beg (make-marker))
- (setq match-end (make-marker))
- (save-match-data
- (while (< pos (point-max))
- (cond ((search-forward ";" nil t)
- (set-marker match-beg (match-beginning 0))
- (set-marker match-end (match-end 0)))
- (t
- (set-marker match-beg (point-max))
- (set-marker match-end (point-max))))
- (funcall decoder pos match-beg)
- (setq result (cons (buffer-substring pos match-beg) result))
- (set-marker pos (marker-position match-end))))
- (setq result (nreverse result))
- (vcard-set-property proplist "encoding" nil))
- (t
- (setq result (vcard-split-string (buffer-string) ";")))))
- (goto-char (point-max))
- result))
-
-(defun vcard-parse-file (filename)
- "Parse FILENAME as a vCard object and return it.
-Parsing occurs with `vcard-parse-region'."
- (let ((result nil))
- (with-temp-buffer
- (insert-file filename)
- (setq result (vcard-parse-region (point-min) (point-max))))
- (if result
- result
- (error "FILENAME parsing error !"))))
-
-
-;;; Functions for retrieving property or value information from parsed
-;;; vcard attributes.
-
-(defun vcard-values (vcard have-props &optional non-props limit)
- "Return the values in VCARD.
-This function is like `vcard-ref' and takes the same arguments, but return
-only the values, not the associated property lists."
- (mapcar 'cdr (vcard-ref vcard have-props non-props limit)))
-
-(defun vcard-ref (vcard have-props &optional non-props limit)
- "Return the attributes in VCARD with HAVE-PROPS properties.
-Optional arg NON-PROPS is a list of properties which candidate attributes
-must not have.
-Optional arg LIMIT means return no more than that many attributes.
-
-The attributes in VCARD which have all properties specified by HAVE-PROPS
-but not having any specified by NON-PROPS are returned. The first element
-of each attribute is the actual property list; the remaining elements are
-the values.
-
-If a specific property has an associated parameter \(e.g. an encoding\),
-use the syntax \(\"property\" . \"parameter\"\) to specify it. If property
-parameter is not important or it has no specific parameter, just specify
-the property name as a string."
- (let ((attrs vcard)
- (result nil)
- (count 0))
- (while (and attrs (or (null limit) (< count limit)))
- (and (vcard-proplist-all-properties (car (car attrs)) have-props)
- (not (vcard-proplist-any-properties (car (car attrs)) non-props))
- (setq result (cons (car attrs) result)
- count (1+ count)))
- (setq attrs (cdr attrs)))
- (nreverse result)))
-
-(defun vcard-proplist-all-properties (proplist props)
- "Returns nil unless PROPLIST contains all properties specified in PROPS."
- (let ((result t))
- (while (and result props)
- (or (vcard-get-property proplist (car props))
- (setq result nil))
- (setq props (cdr props)))
- result))
-
-(defun vcard-proplist-any-properties (proplist props)
- "Returns `t' if PROPLIST contains any of the properties specified in PROPS."
- (let ((result nil))
- (while (and (not result) props)
- (and (vcard-get-property proplist (car props))
- (setq result t))
- (setq props (cdr props)))
- result))
-
-(defun vcard-get-property (proplist property)
- "Return the value from PROPLIST of PROPERTY.
-PROPLIST is a vcard attribute property list, which is normally the first
-element of each attribute entry in a vcard."
- (or (and (member property proplist) t)
- (cdr (assoc property proplist))))
-
-(defun vcard-set-property (proplist property value)
- "In PROPLIST, set PROPERTY to VALUE.
-PROPLIST is a vcard attribute property list.
-If VALUE is nil, PROPERTY is deleted."
- (let (elt)
- (cond ((null value)
- (vcard-delete-property proplist property))
- ((setq elt (member property proplist))
- (and value (not (eq value t))
- (setcar elt (cons property value))))
- ((setq elt (assoc property proplist))
- (cond ((eq value t)
- (setq elt (memq elt proplist))
- (setcar elt property))
- (t
- (setcdr elt value))))
- ((eq value t)
- (nconc proplist (cons property nil)))
- (t
- (nconc proplist (cons (cons property value) nil))))))
-
-(defun vcard-delete-property (proplist property)
- "Delete from PROPLIST the specified property PROPERTY.
-This will not succeed in deleting the first member of the proplist, but
-that element should never be deleted since it is the primary key."
- (let (elt)
- (cond ((setq elt (member property proplist))
- (delq (car elt) proplist))
- ((setq elt (assoc property proplist))
- (delq (car (memq elt proplist)) proplist)))))
-
-(defun vcard-get-attribute (vcard index)
- "Return the INDEXth attribute from VCARD.
-Return nil if INDEX is out of bounds"
- (cond ((or (< index 0) (>= index (length vcard)))
- nil)
- (t
- (nth index vcard))))
-
-(defun vcard-get-named-attribute (vcard attr-name)
- (let (attr result)
- (dolist (attr vcard)
- (if (equal attr-name (vcard-attr-get-name attr))
- (setq result attr)))
- result))
-
-(defun vcard-set-attribute (vcard index attribute)
- "Set ATTRIBUTE as the new INDEXth attribute in VCARD in a destructive way.
-Do nothing if INDEX is out of bounds."
- (cond ((or (< index 0) (>= index (length vcard)))
- nil)
- (t
- (setcar (nthcdr index vcard) attribute))))
-
-
-(defun vcard-get-indexed-property (proplist index)
- "Return the INDEXth property from PROPLIST.
-Return nil if INDEX if out of bounds."
- (cond ((or (< index 0) (>= index (length proplist)))
- nil)
- (t
- (nth index proplist))))
-
-(defun vcard-set-indexed-property (proplist index value)
- "Set VALUE as the new INDEXth parameter value in VCARD in a destructive way.
-Do nothing if INDEX is out of bounds."
- (cond ((or (< index 0) (>= index (length proplist)))
- nil)
- (t
- (let ((prop (nth index proplist)))
- (if (listp prop)
- (setcar (nthcdr index proplist) (cons (car prop) value))
- (setcar (nthcdr index proplist) value))))))
-
-(defun vcard-delete-indexed-property (proplist index)
- "Return a list with the INDEXth property from PROPLIST deleted.
-Do nothing if INDEX is out of bounds."
- (cond ((or (< index 0) (>= index (length proplist)))
- nil)
- (t
- (let ((prop (nth index proplist)))
- (setq proplist (delq prop proplist))))))
-
-(defun vcard-attr-get-values (attr)
- "Return a list with the values of ATTR"
- (cdr attr))
-
-(defun vcard-attr-set-values (attr values)
- "Set VALUES (a list of values) as the ATTR's values, in a destructive way."
- (setcdr attr values))
-
-(defun vcard-attr-get-proplist (attr)
- "Return the properties list of ATTR"
- (car attr))
-
-(defun vcard-attr-set-proplist (attr proplist)
- "Set ATTR's property list to PROPLIST in a destructive way"
- (setcar attr proplist))
-
-(defun vcard-delete-attribute (vcard proplist)
- "Return a VCARD with a properties list equal to PROPLIST deleted
-in a destructive way."
- (let ((elt (assoc proplist vcard)))
- (if elt
- (delq elt vcard))))
-
-(defun vcard-delete-indexed-attribute (vcard index)
- "Return a VCARD with the INDEXth attribute deleted"
- (delete-if (lambda (elt) t)
- vcard
- :start index
- :end (+ index 1)))
-
-(defun vcard-add-attribute (vcard attr)
- "Return a vcard composed of attributes of VCARD plus ATTR"
- (if (not (member attr vcard))
- (setq vcard (reverse (cons attr vcard)))
- vcard))
-
-(defun vcard-get-num-attributes (vcard)
- "Return the number of attributes contained in VCARD"
- (length vcard))
-
-(defun vcard-attr-get-name (attr)
- "Return the first property of ATTR"
- (car (vcard-attr-get-proplist attr)))
-
-(defun vcard-attr-get-parameter (attr property)
- "Return the parameter value associated with PROPERTY in ATTR.
-Return nil if PROPERTY is not a property of ATTR."
- (let* ((proplist (vcard-attr-get-proplist attr))
- (result nil))
- (dolist (prop proplist nil)
- (if (listp prop)
- (if (equal property (car prop))
- (setq result (cons (cdr prop) result)))
- (if (equal property prop)
- (setq result (cons t result)))))
- result))
-
-(defun vcard-attr-set-property (attr property value)
- (let ((proplist (vcard-attr-get-proplist attr)))
- (vcard-set-property proplist property value)))
-
-(defun vcard-attr-add-property (attr property value)
- "Add a new property to ATTR with PROPERTY and VALUE"
- (let ((proplist (vcard-attr-get-proplist attr)))
- (setcdr proplist (cons (cons property value) (cdr proplist)))
- (vcard-attr-set-proplist attr proplist)))
-
-(defun vcard-attr-remove-property (attr property value)
- "Remove the PROPERTY-VALUE in ATTR"
- (let ((proplist (vcard-attr-get-proplist attr))
- prop i prop-index-to-delete)
- (dotimes (i (length proplist))
- (setq prop (nth i proplist))
- (if (or (and (listp prop)
- (equal (car prop) property)
- (equal (cdr prop) value))
- (and (not (listp prop))
- (equal value t)
- (equal prop property)))
- (setq prop-index-to-delete i)))
- (if prop-index-to-delete
- (setq proplist (vcard-delete-indexed-property proplist
- prop-index-to-delete)))
- (vcard-attr-set-proplist attr proplist)))
-
-
-;;; Vcard writing routines
-
-(defun vcard-insert (vcard)
- "Insert the textual representation of VCARD in the current buffer.
-Leave the point after the last inserted character.
-VCARD is a parsed vCard."
- (insert "begin: vcard")
- (insert "\n")
- (dolist (attr vcard)
- (let ((proplist (vcard-attr-get-proplist attr))
- (values (vcard-attr-get-values attr)))
- (dotimes (i (length proplist))
- (let ((prop (nth i proplist)))
- (if (listp prop)
- (insert (concat (car prop)
- "="
- (cdr prop)))
- (insert prop)))
- (if (not (equal i (- (length proplist) 1)))
- (insert ";")))
- (insert ":")
- (insert " ")
- (dotimes (i (length values))
- (let ((value (nth i values)))
- (insert value)
- (if (not (equal i (- (length values) 1)))
- (insert ";"))))
- (insert "\n")))
- (insert "end: vcard"))
-
-(defun vcard-to-string (vcard)
- "Return a string with VCARD's textual representation"
- (save-excursion
- (with-temp-buffer
- (vcard-insert vcard)
- (buffer-substring (point-min) (point-max)))))
-
-
-
-
-;;; Vcard data filters.
-;;;
-;;; Filters receive both the property list and value list and may modify
-;;; either in-place. The return value from the filters are ignored.
-;;;
-;;; These filters can be used for purposes such as removing HTML tags or
-;;; normalizing phone numbers into a standard form.
-
-(defun vcard-standard-filter (proplist values)
- "Apply filters in `vcard-standard-filters' to attributes."
- (vcard-filter-apply-filter-list vcard-standard-filters proplist values))
-
-;; This function could be used to dispatch other filter lists.
-(defun vcard-filter-apply-filter-list (filter-list proplist values)
- (while filter-list
- (funcall (car filter-list) proplist values)
- (setq filter-list (cdr filter-list))))
-
-;; Some lusers put HTML (or even javascript!) in their vcards under the
-;; misguided notion that it's a standard feature of vcards just because
-;; Netscape supports this feature. That is wrong; the vcard specification
-;; does not define any html content semantics and most MUAs cannot do
-;; anything with html text except display them unparsed, which is ugly.
-;;
-;; Thank Netscape for abusing the standard and damned near rendering it
-;; useless for interoperability between MUAs.
-;;
-;; This filter does a very rudimentary job.
-(defun vcard-filter-html (proplist values)
- "Remove HTML tags from attribute values."
- (save-match-data
- (while values
- (while (string-match "<[^<>\n]+>" (car values))
- (setcar values (replace-match "" t t (car values))))
- (setq values (cdr values)))))
-
-(defun vcard-filter-adr-newlines (proplist values)
- "Replace newlines with \"; \" in `adr' values."
- (and (vcard-get-property proplist "adr")
- (save-match-data
- (while values
- (while (string-match "[\r\n]+" (car values))
- (setcar values (replace-match "; " t t (car values))))
- (setq values (cdr values))))))
-
-(defun vcard-filter-tel-normalize (proplist values)
- "Normalize telephone numbers in `tel' values.
-Spaces and hyphens are replaced with `.'.
-US domestic telephone numbers are replaced with international format."
- (and (vcard-get-property proplist "tel")
- (save-match-data
- (while values
- (while (string-match "[\t._-]+" (car values))
- (setcar values (replace-match " " t t (car values))))
- (and (string-match "^(?\\(\\S-\\S-\\S-\\))? ?\
-\\(\\S-\\S-\\S- \\S-\\S-\\S-\\S-\\)"
- (car values))
- (setcar values
- (replace-match "+1 \\1 \\2" t nil (car values))))
- (setq values (cdr values))))))
-
-(defun vcard-filter-textprop-cr (proplist values)
- "Strip carriage returns from text values."
- (and (vcard-proplist-any-properties
- proplist '("adr" "email" "fn" "label" "n" "org" "tel" "title" "url"))
- (save-match-data
- (while values
- (while (string-match "\r+" (car values))
- (setcar values (replace-match "" t t (car values))))
- (setq values (cdr values))))))
-
-
-;;; Decoding methods.
-
-(defmacro vcard-hexstring-to-ascii (s)
- (if (string-lessp emacs-version "20")
- `(format "%c" (car (read-from-string (format "?\\x%s" ,s))))
- `(format "%c" (string-to-number ,s 16))))
-
-(defun vcard-region-decode-quoted-printable (&optional beg end)
- (save-excursion
- (save-restriction
- (save-match-data
- (narrow-to-region (or beg (point-min)) (or end (point-max)))
- (goto-char (point-min))
- (while (re-search-forward "=\n" nil t)
- (delete-region (match-beginning 0) (match-end 0)))
- (goto-char (point-min))
- (while (re-search-forward "=[0-9A-Za-z][0-9A-Za-z]" nil t)
- (let ((s (buffer-substring (1+ (match-beginning 0)) (match-end 0))))
- (replace-match (vcard-hexstring-to-ascii s) t t)))))))
-
-(defun vcard-region-decode-base64 (&optional beg end)
- (save-restriction
- (narrow-to-region (or beg (point-min)) (or end (point-max)))
- (save-match-data
- (goto-char (point-min))
- (while (re-search-forward "[ \t\r\n]+" nil t)
- (delete-region (match-beginning 0) (match-end 0))))
- (goto-char (point-min))
- (let ((count 0)
- (n 0)
- (c nil))
- (while (not (eobp))
- (setq c (char-after (point)))
- (delete-char 1)
- (cond ((char-equal c ?=)
- (if (= count 2)
- (insert (lsh n -10))
- ;; count must be 3
- (insert (lsh n -16) (logand 255 (lsh n -8))))
- (delete-region (point) (point-max)))
- (t
- (setq n (+ n (aref vcard-region-decode-base64-table
- (vcard-char-to-int c))))
- (setq count (1+ count))
- (cond ((= count 4)
- (insert (logand 255 (lsh n -16))
- (logand 255 (lsh n -8))
- (logand 255 n))
- (setq n 0 count 0))
- (t
- (setq n (lsh n 6))))))))))
-
-
-(defun vcard-split-string (string &optional separator limit)
- "Split STRING at occurences of SEPARATOR. Return a list of substrings.
-Optional argument SEPARATOR can be any regexp, but anything matching the
- separator will never appear in any of the returned substrings.
- If not specified, SEPARATOR defaults to \"[ \\f\\t\\n\\r\\v]+\".
-If optional arg LIMIT is specified, split into no more than that many
- fields \(though it may split into fewer\)."
- (or separator (setq separator "[ \f\t\n\r\v]+"))
- (let ((string-list nil)
- (len (length string))
- (pos 0)
- (splits 0)
- str)
- (save-match-data
- (while (<= pos len)
- (setq splits (1+ splits))
- (cond ((and limit
- (>= splits limit))
- (setq str (substring string pos))
- (setq pos (1+ len)))
- ((string-match separator string pos)
- (setq str (substring string pos (match-beginning 0)))
- (setq pos (match-end 0)))
- (t
- (setq str (substring string pos))
- (setq pos (1+ len))))
- (setq string-list (cons str string-list))))
- (nreverse string-list)))
-
-(defun vcard-copy-tree (tree)
- "Make a deep copy of nested conses."
- (cond
- ((consp tree)
- (cons (vcard-copy-tree (car tree))
- (vcard-copy-tree (cdr tree))))
- (t tree)))
-
-(defun vcard-flatten (l)
- (if (consp l)
- (apply 'nconc (mapcar 'vcard-flatten l))
- (list l)))
-
-(provide 'vcard)
-
-;;; vcard.el ends here.
| [Prev in Thread] |
Current Thread |
[Next in Thread] |
- [commit-womb] addressbook COPYING ChangeLog Makefile README a...,
Jose E. Marchesi <=